Klasör içerisindeki excel dosyalarını tek dosyada birleştirme

[yyhy]

Klasör içerisindeki excel dosyalarını tek dosyada birleştirmek istiyorum. ADO yöntemi kullanılan dosyaları indirip uyarlamaya çalıştım ama bir türlü birleştiremedim. ADO yöntemi ile kapalı dosyalardan verileri tek dosyaya toplayabilir miyiz?
Kriterler
1 - BİRİM (1).............BİRİM (50) ye kadar 50 adet bir klasör içerisinde dosyam var.
2 - Kapalı olan BİRİM (1)........BİRİM (50) ye kadar xlsm dosyalarından 00 - Tüm Veri Dosyası"na verileri çekmek istiyorum.
3 - Dosya içerisindeki formatlar aynıdır. Sütunlar sabit olup satırlara girilen veriler değişebiliyor. 5 satır 16 satır gibi. Kimi birimde ise 50 satır olabiliyor.
4 - Dosya içerisinde kişisel bilgi yoktur, deneme verileri oluşturulmuştur.
Yardımcı olabilecek arkadaşlara şimdiden teşekkür ederim.

 

[ÖmerFaruk]

Aşağıdaki kodu TümVeri sayfanızda çalıştırabilisiniz.
Not: Forumda arattım ve buldum, küçük bir döngü ilavesi yaptım.

Sub Test2()
'   Haluk - 03/03/2020
'   sa4truss@gmail.com

    Dim adoCN As Object, RS As Object
    Dim myFile As String, strSQL As String
    Dim strLastData As String
    
    mySelect = "[SİCİL],[Rütbesi],[KODU], [Adı SOYADI], [TELEFON], [BİRİM], [CİNSİYET], [DİĞER], [PAZARTESİ], [SALI],[ÇARŞAMBA], [PERŞEMBE], [CUMA], [CUMARTESİ], [PAZAR], [AÇIKLAMA]"
    Const adOpenKeyset = 1
For i = 1 To 50
    myFile = ThisWorkbook.Path & Application.PathSeparator & "BİRİM (" & i & ").xlsx"
    
    Set adoCN = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")
 
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = myFile
    adoCN.Properties("Extended Properties") = "Excel 12.0 Macro; HDR=yes; IMEX=1"
    adoCN.Open
 
    strSQL = "Select " & mySelect & " from [MEMURLAR$] where [SİCİL] is not null"
    
    RS.CursorType = adOpenKeyset
    RS.Open strSQL, adoCN
    SonSat = Range("B" & Rows.Count).End(xlUp).Row + 1
    If RS.RecordCount > 0 Then
       Sheets("TümVeri").Range("B" & SonSat).CopyFromRecordset RS
    End If
    RS.Close
    adoCN.Close
Next i
    Set RS = Nothing
    Set adoCN = Nothing
    
    Range("A2") = 1
    Range("A2:A" & Range("B" & Rows.Count).End(xlUp).Row).Select
    Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
    Range("A2").Select
End Sub

 

[Haluk]

@NextLevel ;

Nezaketiniz için teşekkürler....

.

 

[yyhy]

Sayın @NextLevel ve @Haluk bey teşekkürler.
Sayın @NextLevel örnek dosyamda deneyip bilgi vereceğim.

 

[yyhy]

Sayın @NextLevel macroyu bir modül ekleyip uyguladım ama hata alıyorum. Acaba neyi yanlış yaptım.

 

[ÖmerFaruk]

Veri alacağınız Birim (1)..(50) çalışma kitaplarının hepsinin
kodlarınızın olduğu kitapla aynı klasörde ve kapalı olması şart.

 

[yyhy]

Teşekkürler. Emeğinize sağlık.