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

Ayrıca a sütunu seri numaralansın isterseniz alttaki kodu ekleyin.

        If WorksheetFunction.CountA(.Range("B2:B" & Rows.Count)) > 0 Then

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

            .Range("A2").Value = 1

          .Range("A2:A" & son).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Stop:=son

        End If

(22/04/2021, 11:57)feraz yazdı: .Range("A" & son & ":A" & Rows.Count).Clear

Ya 10.mesajdaki yukardaki kodu alttaki gibi yapınki A sütunu silinsin.O kodun yukarısındaki son= ile olan stırda silinebilir.
Bir konuya daha bir sürü mesaj yazdım

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

bu da @feraz hocamınkinden biraz farklı bir yöntem, sadece arşivde bulunsun istedim, ama verileri alırken türü metinmiş gibi alıyor, yeşil üçgenler kaplıyor ortalığı)

Sub VeriAl()

    

    Dim con As ADODB.Connection

    Set con = New ADODB.Connection

    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=yes;"""

    

    yol = ThisWorkbook.Path & Application.PathSeparator

    yol2 = Dir(yol & "*xlsx")

    

    txtAlan = "[0], [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]"

        

        With ThisWorkbook.Sheets("TümVeri")

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

        Do Until yol2 = ""

             txtSql = "INSERT INTO  [TümVeri$] (" & txtAlan & ") " & _

                      "SELECT  " & txtAlan & " " & _

                      "FROM [MEMURLAR$] IN '" & yol & yol2 & "'[EXCEL 8.0;] " & _

                      "where ([SİCİL] Is Not Null);"

             con.Execute txtSql

        

        yol2 = Dir

        Loop

    End With



    con.Close: Set con = Nothing



    MsgBox "Bitti", vbInformation, "Bilgi"

End Sub

Sayın feraz bey macroyu birleştirmeye çalışıyordum. Son macroyu uygularsam tamam olurmu acaba bir onu deneyeyim

yada alanları kullanmadan

Sub VeriAl_alansiz()

   

    Dim con As ADODB.Connection

    Set con = New ADODB.Connection

    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=yes;"""

    

    yol = ThisWorkbook.Path & Application.PathSeparator

    yol2 = Dir(yol & "*xlsx")

        

        With ThisWorkbook.Sheets("TümVeri")

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

        Do Until yol2 = ""

             txtSql = "INSERT INTO  [TümVeri$]  " & _

                      "SELECT  * " & _

                      "FROM [MEMURLAR$] IN '" & yol & yol2 & "'[EXCEL 8.0;] " & _

                      "where ([SİCİL] Is Not Null);"

             con.Execute txtSql

        

        yol2 = Dir

        Loop

    End With



    con.Close: Set con = Nothing



    MsgBox "Bitti", vbInformation, "Bilgi"

End Sub