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