Soru farklı excel kitaplarındaki verileri bir araya toplama

[nes432]

merhaba,

bir makroya ihtiyacım var. bir klasörün içinde aynı isimde sadece sonunda (1), (2) şeklinde değişen isimli 190 civarı excel kitabım var bu exceldeki verileri yeni bir kitapta toplamak istiyorum. Konu çok acil yardımcı olursanız beni büyük bi eziyetten kurtarmış olacaksınız. Şimdiden teşekkür ederim.
Dosya linkim (detaylı açıklamalar içerikte)
http://s7.dosya.tc/server14/hmjba7/Policy__1_.xlsx.html

 

[veyselemre]

Sub veriCek()
   Sheets("AÇIKLAMA").Select
    Range("B:XFD").ClearContents
    Set adoCN = CreateObject("ADODB.Connection")
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open
    Set rs = CreateObject("Adodb.RecordSet")
    pth = ThisWorkbook.Path & "\"
    For i = 1 To 200 ' Dosya Numarasını yazın
        fName = "Policy (" & i & ")"
        FullName = pth & fName & ".xlsx"
        If Dir(FullName) <> "" Then
            strSQL = "Select Country, Total/11 From [High level$] IN '' [Excel 12.0;Database=" & FullName & "]"
            rs.Open strSQL, adoCN, 1, 1
            sut = i * 2
            Cells(2, sut).Value = fName
            Cells(3, sut).CopyFromRecordset rs
            rs.Close
            strSQL = "Select Score, Total From [Intermediate level$] IN '' [Excel 12.0;Database=" & FullName & "]"
            rs.Open strSQL, adoCN, 1, 1
            Cells(4, sut).Resize(, 2).Value = Array("Score", "Total")
            Cells(5, sut).CopyFromRecordset rs
            rs.Close
        End If
    Next i
    adoCN.Close
    Set rs = Nothing
    Set adoCN = Nothing
End Sub

 

[nes432]

Sub veriCek()
   Sheets("AÇIKLAMA").Select
    Range("B:XFD").ClearContents
    Set adoCN = CreateObject("ADODB.Connection")
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open
    Set rs = CreateObject("Adodb.RecordSet")
    pth = ThisWorkbook.Path & "\"
    For i = 1 To 200 ' Dosya Numarasını yazın
        fname = "Policy (" & i & ")"
        FullName = pth & fname & ".xlsx"
        If Dir(pth & fname & ".xlsx") <> "" Then
            strSQL = "Select Country, Total/11 From [High level$] IN '' [Excel 12.0;Database=" & FullName & "]"
            rs.Open strSQL, adoCN, 1, 1
            sut = i * 2
            Cells(2, sut).Value = fname
            Cells(3, sut).CopyFromRecordset rs
            rs.Close
            strSQL = "Select Score, Total From [Intermediate level$] IN '' [Excel 12.0;Database=" & FullName & "]"
            rs.Open strSQL, adoCN, 1, 1
            sut = i * 2
            Cells(4, sut).Resize(, 2).Value = Array("Score", "Total")
            Cells(5, sut).CopyFromRecordset rs
            rs.Close
        End If
    Next i
    adoCN.Close
    Set rs = Nothing
    Set adoCN = Nothing
    Application.CutCopyMode = False
End Sub

çok teşekkür ediyorum. Harika olmuş koca üç gün uğraşmaktan kurtardınız beni. Ömrünüz cennet olsun