[]
Çok sayıda excel dosyasını tek sheet'te açabilmek mümkün müdür?
selam romalılar
şimdi bi sıcaklık ölçer cihaz var 15 dakikada bir ölçüm alıp gün sonunda excel sheet oluşturuyor
bunu her gün yapıyor ama her gün için ayrı bir excel dosyası oluşturuyor
ben şimdi bu değerlerin yıllık grafiğini çıkarıcam
365 dosyayı tek tek açmama gerek kalmadan yapabileceğim bir yol var mıdır?
şimdi bi sıcaklık ölçer cihaz var 15 dakikada bir ölçüm alıp gün sonunda excel sheet oluşturuyor
bunu her gün yapıyor ama her gün için ayrı bir excel dosyası oluşturuyor
ben şimdi bu değerlerin yıllık grafiğini çıkarıcam
365 dosyayı tek tek açmama gerek kalmadan yapabileceğim bir yol var mıdır?
bir lokasyondaki excelleri okuyup bunları tek sayfaya yazacağpın bir VBA kodu yazman gerekir
- €xpolerer
(23.06.16 15:14:49)
merhaba böyle bir kodu bir forumda buldum. ama nasıl çalıştırabileceğimi bilmiyorum. nasıl çalıştırabilirim?
- dierache
(23.06.16 16:08:11)
boş bir excel açıkken alt ile birlikte F11 tuşuna basarsan bir ekran açılır soltaraftaki alandan sayfa1'e çift tıklarsan kodu yapıştıracağın alan açılacak
- €xpolerer (23.06.16 16:11:14)
şöyle bir kod buldum. ama bende çalışmadı. dosyayı oluşturuyor ama oluşan dosya boş.
Option Explicit
Sub DOSYALARDAN_VERİ_AL()
Dim K1 As Workbook, K2 As Workbook
Dim K3 As Workbook, S1 As Worksheet
Dim X As Integer, Satır As Integer, Son_Satır As Long
Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String
Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçin", 50, &H0)
If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
ElseIf Not Klasör Is Nothing Then
Kaynak_Klasör = Klasör.Items.Item.Path
Else
MsgBox "İşleme devam edbilmek için klasör seçimi yapmalısınız !" & Chr(10) & _
"İşleminiz iptal edilmiştir.", vbCritical
Exit Sub
End If
On Error Resume Next
Set K1 = ThisWorkbook
Set K2 = Workbooks.Add(1)
Dosya = Dir(Kaynak_Klasör & "\*.xls")
Satır = 2
Application.ScreenUpdating = False
Do
If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya") = 0 Then
DoEvents
Application.DisplayAlerts = False
Set K3 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
Application.DisplayAlerts = True
Set S1 = K3.Sheets(1)
Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
S1.Range("A2:AA" & Son_Satır).Copy _
K2.Sheets("Sayfa1").Range("A" & Satır)
Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2
K3.Close True
Dosya = Dir
Else
Dosya = Dir
End If
Loop While Dosya <> ""
K2.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
K2.SaveAs (Kaynak_Klasör & "\Dosya_" & Format(Now, "dd_mm_yyyy_hh_mm_ss"))
K2.Close True
Set K1 = Nothing
Set K2 = Nothing
Set K3 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Option Explicit
Sub DOSYALARDAN_VERİ_AL()
Dim K1 As Workbook, K2 As Workbook
Dim K3 As Workbook, S1 As Worksheet
Dim X As Integer, Satır As Integer, Son_Satır As Long
Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String
Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçin", 50, &H0)
If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
ElseIf Not Klasör Is Nothing Then
Kaynak_Klasör = Klasör.Items.Item.Path
Else
MsgBox "İşleme devam edbilmek için klasör seçimi yapmalısınız !" & Chr(10) & _
"İşleminiz iptal edilmiştir.", vbCritical
Exit Sub
End If
On Error Resume Next
Set K1 = ThisWorkbook
Set K2 = Workbooks.Add(1)
Dosya = Dir(Kaynak_Klasör & "\*.xls")
Satır = 2
Application.ScreenUpdating = False
Do
If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya") = 0 Then
DoEvents
Application.DisplayAlerts = False
Set K3 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
Application.DisplayAlerts = True
Set S1 = K3.Sheets(1)
Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
S1.Range("A2:AA" & Son_Satır).Copy _
K2.Sheets("Sayfa1").Range("A" & Satır)
Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2
K3.Close True
Dosya = Dir
Else
Dosya = Dir
End If
Loop While Dosya <> ""
K2.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
K2.SaveAs (Kaynak_Klasör & "\Dosya_" & Format(Now, "dd_mm_yyyy_hh_mm_ss"))
K2.Close True
Set K1 = Nothing
Set K2 = Nothing
Set K3 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
- dierache (23.06.16 16:30:17)
vallaha çalıştırdım. bendeki dosyaların uzantısı .csv olduğundan koddaki .xls uzantısını .csv ile değiştirdim ve çalıştı.
- dierache (23.06.16 16:40:06)
ben de çalıştı,
excellerin olduğu yere Dosya_23_06_2016_16_42_15 isimli bir dosya oluşturdu.
işleminiz tamamlnlıştır diye mesaj çıktı mı
excellerin olduğu yere Dosya_23_06_2016_16_42_15 isimli bir dosya oluşturdu.
işleminiz tamamlnlıştır diye mesaj çıktı mı
- €xpolerer (23.06.16 16:44:53)
evet çalıştı bende de. ancak her birleştirme sonunda bir satır boşluk var. sebebini anlayacak kadar kod bilgim yok maalesef.
- dierache (23.06.16 16:48:51)
1
