Alttaki kod çalışırsa daha iyi bende çalışıyor.Yani 65536 satır sonrası için öncekinde sorun olabilir onun için bu kodu yazdım.

Private Sub CommandButton1_Click()

    Dim rs As Object, con As Object

    Dim son As Long, alan As String, baslik As Range

    

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

        For Each baslik In .Range("B1:Q1")

            alan = alan & "[" & baslik.Value & "]" & ","

        Next

        alan = Mid(alan, 1, Len(alan) - 1)

        .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 " & alan & " from [MEMURLAR$]", con, 1, 1

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

                rs.Close

                con.Close

                Sql = vbNullString

            yol2 = Dir

        Loop

    End With

    Set rs = Nothing

    Set con = Nothing: Set baslik = Nothing

    MsgBox "Bitti", vbInformation, "Bilgi"

End Sub