Soru dosyaları birleştirme

[incsoft]

Arkadaşlar hazırda kullanmış olduğunuz dosyaları alt alta birleştiren bir macrolu ya da başka bir mantıkla çalışan bir dosya varmıdır? Örneğin elimde 5000 satırdan oluşan aşağıdaki isimlerde dosyalar olduğunu varsayalım. Bu program ya da macro bu dosyaların içeriklerinin alt alta getirecek ve data.xlsx olarak belirtilen konuma kaydedecek. Bunu nasıl yapabiliriz acaba? Şuan da 1 macro ile yapıyorum ancak sadece 1 dosya ile birleştirme yapıyor.

2010.xlsx
2011.xlsx
2012.xlsx
2013.xlsx
2014.xlsx
2015.xlsx
2016.xlsx
2017.xlsx
2018.xlsx
2019.xlsx
2020.xlsx


Private Sub CommandButton1_Click()
Application.DisplayAlerts = False
Dim Con As Object, rs As Object, Sorgu As String, dosya As String, son As String
Dim Kayıt_Yeri As String, Sayfa_adi As String

Sayfa_adi = "Sheet1"
dosya = "crystal.XLSX"

Kayıt_Yeri = ThisWorkbook.Path & "\" & dosya

Set Con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.RecordSet")
Con.Open = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & Kayıt_Yeri & ";Extended Properties=""Excel 12.0;HDR=yes"""

Sorgu = "Select * from [" & Sayfa_adi & "$] "
rs.Open Sorgu, Con, 1, 1

son = Cells(Rows.Count, 1).End(3).Row + 1

Range("A" & son).CopyFromRecordset rs
rs.Close: Con.Close
Set Con = Nothing: Set rs = Nothing: Sorgu = ""
atla:

Application.DisplayAlerts = True
MsgBox "Birleştirme işlemi başarıyla tamamlanmıştır."
End Sub