Çözüldü excelde birçok çalışma kitabındaki tabloları tek bir sayfada toplama

Sub XL_birlestir()
Dim FSO As Object '//FileSystemObject
Dim f As Object '//File Object
AnaKlsr = ThisWorkbook.Path & "\Data\"

Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO
        For Each f In .GetFolder(AnaKlsr).Files
            If Left(f.Name, 2) <> "~$" Then
                If Left(f.Name, InStr(f.Name, ".") - 1) <> "Kitap1" Then
                    hySQL = hySQL & SyfAdiAl(f.Path, Left(f.Name, InStr(f.Name, ".") - 1) & "_GENEL$")
                Else
                    hySQL = hySQL & Ktp1(f.Path)
                End If
            End If
        Next f
End With
Dim SQL As String
SQL = Mid(hySQL, 11)

'hy_____________________________________recordsete alma
Dim ADO_RS As ADODB.Recordset
Dim ADO_CN As ADODB.Connection

Set ADO_RS = New ADODB.Recordset
Set ADO_CN = New ADODB.Connection

ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & _
                          ";extended properties=""excel 8.0;hdr=No"""
ADO_CN.Open
ADO_RS.Open SQL, ADO_CN, 3, 1

'   Eğer Hiç Kayıt Yoksa
If ADO_RS.RecordCount = 0 Then
    MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
    GoTo son
End If

sonstr = Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Sonuc").Range("A2:K" & sonstr).Clear
Sheets("Sonuc").Range("A2").CopyFromRecordset ADO_RS

son:
ADO_RS.Close
ADO_CN.Close
Set ADO_RS = Nothing
Set ADO_CN = Nothing
MsgBox "işlem tamam"
End Sub

Function Ktp1(fn As String) As String
    Dim conn As Object, db As Object
    Dim tbl As Object

    Set conn = CreateObject("DAO.DBEngine.120")
    Set db = conn.OpenDatabase(fn, False, True, "Excel 12.0 Xml;HDR=Yes;")
    xSQL = ""

    For Each tbl In db.TableDefs
 
    If Right(tbl.Name, 7) = "_GENEL$" Then
    tblAdi = CStr(Replace(tbl.Name, "'", ""))
            xSQL = xSQL & "union all " & _
                   "select [" & tbl.Fields(0).Name & "],[" & tbl.Fields(1).Name & "],[" & tbl.Fields(2).Name & _
                   "],[" & tbl.Fields(3).Name & "],[" & tbl.Fields(4).Name & "],[" & tbl.Fields(5).Name & _
                   "],[" & tbl.Fields(6).Name & "],[" & tbl.Fields(7).Name & "] " & _
                   "from [" & tbl.Name & "] IN """ & fn & """ ""EXCEL 8.0;"" where ([HAFTAKOD] Is Not Null)"

    End If
    Next
    Set db = Nothing
    Set conn = Nothing
Ktp1 = xSQL
End Function

Function SyfAdiAl(fn As String, SyfAdi As String) As String
    Dim conn As Object, db As Object
    Dim tbl As Object
On Error Resume Next
    Set conn = CreateObject("DAO.DBEngine.120")
    Set db = conn.OpenDatabase(fn, False, True, "Excel 12.0 Xml;HDR=Yes;")
    xSQL = ""
    Set tbl = db.TableDefs(SyfAdi)
     If (Err.Number = 0) Then
            xSQL = xSQL & "union all " & _
                   "select [" & tbl.Fields(0).Name & "],[" & tbl.Fields(1).Name & "],[" & tbl.Fields(2).Name & "],[" & tbl.Fields(3).Name & _
                   "],[" & tbl.Fields(4).Name & "],''," & _
                   "[" & tbl.Fields(5).Name & "],[" & tbl.Fields(6).Name & "] " & _
                   "from [" & tbl.Name & "] IN """ & fn & """ ""EXCEL 8.0;"" where ([HAFTAKOD] Is Not Null) and [HAFTAKOD] not like 'STO*' "

            xSQL = xSQL & "union all " & _
                   "select [" & tbl.Fields(0).Name & "],[" & tbl.Fields(1).Name & "],[" & tbl.Fields(2).Name & "],[" & tbl.Fields(3).Name & _
                   "],[" & tbl.Fields(4).Name & "],[" & tbl.Fields(5).Name & "],'','' " & _
                   "from [" & tbl.Name & "] IN """ & fn & """ ""EXCEL 8.0;"" where ([HAFTAKOD] Is Not Null) and [HAFTAKOD] like 'STO*' "
    Else
            Err.Clear
    End If
    Set db = Nothing
    Set conn = Nothing
SyfAdiAl = xSQL
End Function