Birden Fazla Excel Verisini Access Te Birleştirmek

ben dosya isimlerini for x döngüsü ile aldım siz dosya isimlerini aldığınız fonksiyonu kullanabilirsiniz

Visual Basic

Private Sub BtnExcelAlAktar_Click()
Dim qdfNew As QueryDef
Dim AktarilanDosya() As String 'aktarılan dosya isimlerini kaydetmek için kullanılacak dizi
Dim AktarilenIndx As Integer
 
AktarilenIndx = 0
Adreshy = CurrentProject.Path & "\Kaynak - " 'dosya adresi
 For x = 1 To 6 ' seçilen dosyaları aktarma döngüsü
    ReDim Preserve AktarilanDosya(AktarilenIndx)
    AktarilanDosya(AktarilenIndx) = "Kaynak - " & x
    DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel12Xml, AktarilanDosya(AktarilenIndx), Adreshy & x & ".xls", 1, "sheet1!"
    SqlSOrgu = "SELECT " & "'Kaynak - " & x & "' AS DosyaAdi, adı, soyadı " & _
               "FROM [" & AktarilanDosya(AktarilenIndx) & "]"
    SqlSOrgu2 = SqlSOrgu2 & " Union all " & SqlSOrgu
 
    AktarilenIndx = AktarilenIndx + 1
 Next x
 
 SqlSOrgu2 = Mid(SqlSOrgu2, 11)
    Set qdfNew = CurrentDb.CreateQueryDef("TmpSorgu", SqlSOrgu2) 'geçici sorgu oluşturma
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "TmpSorgu", CurrentProject.Path & "\Ana.xls", 1 'Aktarılacak ana excel
        DoCmd.DeleteObject acQuery, "TmpSorgu" 'Oluşturulan geçici sorguyu siler
 
For x = LBound(AktarilanDosya) To UBound(AktarilanDosya)
        DoCmd.DeleteObject acTable, AktarilanDosya(x) 'Aktarılan bağlı tabloları siler
 
Next x
 
MsgBox ""
End Sub