Aynı klasör içindeki aynı sayfalardan veri çekmek

[wezyr]

Merhabalar,
aynı klasör içinde yer alan ve aynı şablondan doldurulmuş excel dosyalarının belirli sayfalarından verileri alt alta birleştirmek istiyoruz. Excel dosylarınında sayfa isimleri aynı ve 3 sayfa gizli ve veri alıncak sayfa (hhhh) görünür şekilde. Umarım anlatabilmişimdir. örnek dosya ektedir yardımcı olacak arkadaşlara şimdiden teşekkürler.

 

[wezyr]

güncel

 

[veyselemre]

Sub ADOWithAllFiles()
    Dim fso As Object
    Dim file As Object
    Dim adoCn As Object, rs As Object, strSQL$

    Set fso = CreateObject("Scripting.FileSystemObject")
    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=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")

    Sheets("Sayfa1").Range("A2:AA" & Rows.Count).ClearContents

    For Each file In fso.GetFolder(ThisWorkbook.Path).Files
        If fso.GetExtensionName(file) Like "xlsx" And _
           Not file.Name Like ThisWorkbook.Name And _
           Not file.Name Like "~$*" Then

            strSQL = "Select *,'" & file.Name & "' From [hhhh$A4:Z" & Rows.Count & _
                     "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                     file.Name & "]"
            rs.Open strSQL, adoCn, 1, 1
            Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Offset(1).CopyFromRecordset rs
            rs.Close

        End If
    Next file

End Sub

 

[wezyr]

Sub ADOWithAllFiles()
    Dim fso As Object
    Dim file As Object
    Dim adoCn As Object, rs As Object, strSQL$

    Set fso = CreateObject("Scripting.FileSystemObject")
    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=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")

    Sheets("Sayfa1").Range("A2:AA" & Rows.Count).ClearContents

    For Each file In fso.GetFolder(ThisWorkbook.Path).Files
        If fso.GetExtensionName(file) Like "xlsx" And _
           Not file.Name Like ThisWorkbook.Name And _
           Not file.Name Like "~$*" Then

            strSQL = "Select *,'" & file.Name & "' From [hhhh$A4:Z" & Rows.Count & _
                     "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                     file.Name & "]"
            rs.Open strSQL, adoCn, 1, 1
            Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Offset(1).CopyFromRecordset rs
            rs.Close

        End If
    Next file

End Sub

Teşekkür ederim. Elinize sağlık istediğimden fazlasıyla birlikte yapmışsınız.