Klasör içerisindeki excellerden veri çekme

[mehmetali.bacak]

iyi akşamlar,

klasör içerisindeki excellerden veri çekme ile ilgili yardımınıza ihtiyacım var. örnek olarak dosya gönderiyorum. toplamda 1500 excel dosyam var güncelde. açıklamaları rapor adlı excel dosyasının içerisine yazdım. benim için tek tek yazmak yaklaşık 1 ayımı alacak. şimdiden teşekkür ederim.

 

[ÖmerBey]

Aşağıdaki kodu* rapor dosyanızda boş bir modüle kopyalayarak deneyiniz.
Rapor dosyasının yer aldığı klasörün alt klasörlerini kontrol ederek veri alır.
*Sn. leumruk'un klasördeki dosyaları listeleme kodu kullanılarak yazılmıştır.

Sub KOD()
Application.ScreenUpdating = False
Set s1 = ThisWorkbook.Sheets(1)
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path
Do
Tekrar:
If ds.GetFolder(yol).subfolders.Count > 0 Then
    For Each kls In ds.GetFolder(yol).subfolders
        klslst = klslst & "{" & kls
    Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)
dosya = Dir$(yol & "\*.xls*")
Do While dosya <> ""
    Set w2 = Workbooks.Open(yol & "\" & dosya)
    Set s2 = w2.Sheets(1)
    sat = s1.Range("A65500").End(3).Row + 1
    süt1 = s2.Range("A:Z").Find("değer1").Column
    
    For a = s2.Range("A:Z").Find("değer1").Row To s2.Range("A65500").End(3).Row
        If s2.Cells(a, "A") <> "" Then
            süt = WorksheetFunction.Match(s2.Cells(a, "A"), s1.Range("3:3"), 0)
            s1.Cells(sat, 1) = s2.Range("I14")
            s1.Cells(sat, süt) = s2.Cells(a, süt1)
            s1.Cells(sat, süt + 1) = s2.Cells(a, süt1 + 1)
            s1.Cells(sat, süt + 2) = s2.Cells(a, süt1 + 2)
        End If
    Next
    
    w2.Close
    dosya = Dir$()
Loop
If x = 1 And ds.GetFolder(yol).subfolders.Count > 0 Then GoTo Tekrar
Loop While UBound(deg) <> x
Application.ScreenUpdating = True
MsgBox "Bitti."
End Sub

 

[mehmetali.bacak]

çok fazla makro bilmiyorum rica etsem kodların ne işe yaradığını satır satır yazabilirmisiniz?