Klasör İçerisindeki Excel Dosyalarını Tek Dosyada Birleştirme

Aslında düşününce union all olayına gerek yok abey ektekini deneyin.

Private Sub CommandButton1_Click()

    Dim rs As Object, con As Object

    

    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 = ""

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

                rs.Open "select * from [MEMURLAR$]", con, 1, 1

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

                rs.Close

                con.Close

            yol2 = Dir

        Loop

    End With

    Set rs = Nothing

    Set con = Nothing

    MsgBox "Bitti", vbInformation, "Bilgi"

End Sub

Sayın feraz öncelikle teşekkür ederim. Klasördeki BİRİM (1) dosyasındaki verileri getiriyor. Tam istediğim gibi ama geriye 49 dosya var yani BİRİM (2)........BİRİM (50) ye kadar. Acaba kodda nasıl bir düzenleme yapabiliriz.

Rica ederim abey normalde getiriyor mesela 300.stırdan itibaren bakın.A stunundaki gereksiz satırları silin diye.Ayrıca son stırı buldurupta yaptırılabilir müsit olunca bakarım.

Vakit bulmuşken ayarladım abey.

Private Sub CommandButton1_Click()

    Dim rs As Object, con As Object

    Dim son As Long

    

    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 = ""

                son = .Range("B" & Rows.Count).End(3).Row + 1

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

                rs.Open "select * from [MEMURLAR$]", con, 1, 1

                .Range("A" & son).CopyFromRecordset rs

                rs.Close

                con.Close

            yol2 = Dir

        Loop

      son = .Range("B" & Rows.Count).End(3).Row + 1

      .Range("A" & son & ":A" & Rows.Count).Clear

    End With

    Set rs = Nothing

    Set con = Nothing

    MsgBox "Bitti", vbInformation, "Bilgi"

End Sub

Sayın feraz bey acaba verileri aldığı Birim (01).....Birim (50) sayfalardan veriyi alırken B2:Q aralığını aldırmam için macro kodunda ne gibi değişiklik yapabiliriz? Ayrıca son gönderdiğiniz macroyu deneyeceğim. Teşekkürler. Ayrıca bilgi vereceğim.

Önceki mesajdajdaki dosyayı eklemeyi unutmuşum abey.

---

(22/04/2021, 21:49)yyhy yazdı: Birim (01).....Birim (50) sayfalardan veriyi alırken B2:Q aralığını aldırmam için macro kodunda ne gibi değişiklik yapabiliriz?

Private Sub CommandButton1_Click()

    Dim rs As Object, con As Object

    Dim son As Long

    

    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 = ""

                son = .Range("B" & Rows.Count).End(3).Row + 1

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

                rs.Open "select * from [MEMURLAR$B1:Q]", con, 1, 1

                

                .Range("B" & son).CopyFromRecordset rs

                rs.Close

                con.Close

            yol2 = Dir

        Loop

    End With

    Set rs = Nothing

    Set con = Nothing

    MsgBox "Bitti", vbInformation, "Bilgi"

End Sub