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.

Dosyayı deneyemedim lakin union all ile oluyor heralde sorgu olarak.

Videoyu anlatan adam acayip bişey tavsiye ederim tüm videolarını izlemenizi ingilizce bilmeseniz bile anlıyor insan.Sanırın videodaki gbi istiyorsunuz abey.

Sayın feraz bey web ten benim konu ile ilgili örnek dosyaları inceledim videolara bakmadım. ADO yöntemi kullanılmış.
Dosyalar indirdiğim şekli ile çalışıyorlar benim eklemiş olduğum dosyalara uyarlayamadım. Acaba ne yapabiliriz?

Abey dosyada kod yok ayrıca videoyu izleyip uygulamanızı önermiştim bende uyguladım ufak tefek değişiklik yaparak.
Alttaki kodu deneyin.
Hata olursa koddaki Türkçe karakterleri düzeltin.

Sub test()

    Dim rs As Object, con As Object, Sql As String

    

    Set rs = CreateObject("ADODB.Recordset")

    Set con = CreateObject("ADODB.Connection")

    Dim yol As String, yol2 As String

    

    yol = ThisWorkbook.Path & Application.PathSeparator

    yol2 = Dir(yol & "*xlsx")



    With ThisWorkbook.Sheets("TümVeri")

        .Range("A2:Q" & Rows.Count).Clear

        Do Until yol2 = ""

            If Not yol2 Like "00 -Tüm Veri*" Then

                con.Open "Provider=microsoft.ace.oledb.12.0;data source=" & yol & yol2 & ";extended properties=""Excel 12.0;hdr=yes"""

                Sql = Sql & " union all select * from [MEMURLAR$]"

                Sql = Mid(sql, 12)

                rs.Open sql, con, 1, 1

                .Range("A" & Rows.Count).End(3)(2, 1).CopyFromRecordset rs

                Sql = ""

                rs.Close

                con.Close

            End If

            yol2 = Dir

        Loop

    End With

    Set rs = Nothing

    Set con = Nothing

End Sub

Dosyayıda ekleyeyim bari

Eğer verilerin geleceği Excel Formatı xlsx değilse  If Not yol2 Like "00 -Tüm Veri*" Thenve End if kısmını silebilirsiniz.Bende bu dosyada pasif yaptım.
A sütunudaki gereksiz satırları silinki doğru çalışsın alt alta.

Private Sub CommandButton1_Click()

    Dim rs As Object, con As Object, Sql As String

    

    Set rs = CreateObject("ADODB.Recordset")

    Set con = CreateObject("ADODB.Connection")

    Dim yol As String, yol2 As String

    

    yol = ThisWorkbook.Path & Application.PathSeparator

    yol2 = Dir(yol & "*xlsx")



    With ThisWorkbook.Sheets("TümVeri")

        .Range("A2:Q" & Rows.Count).Clear

        Do Until yol2 = ""

'            If Not yol2 Like "00 -Tüm Veri*" Then

                con.Open "Provider=microsoft.ace.oledb.12.0;data source=" & yol & yol2 & ";extended properties=""Excel 12.0;hdr=yes"""

                Sql = Sql & " union all select * from [MEMURLAR$]"

                Sql = Mid(sql, 12)

                rs.Open sql, con, 1, 1

                .Range("A" & Rows.Count).End(3)(2, 1).CopyFromRecordset rs

                Sql = ""

                rs.Close

                con.Close

'            End If

            yol2 = Dir

        Loop

    End With

    Set rs = Nothing

    Set con = Nothing

    MsgBox "Bitti", vbInformation, "Bilgi"

End Sub