Excell Dosyalarını Tek Sayfada Altalta birleştirme

[ORHANGN]

Selamlar,

Farklı excell dosyalarını tek bir excell dosyasında alt alta birleştirmeye yarayan aşağıdaki makroya birleştirilen dosyada ilgili verilerin en sağındaki satıra ilk dosyanın adını vermek mümkün müdür?

Sub DOSYALARDAN_VERİ_AL()
Dim K1 As Workbook, K2 As Workbook
Dim K3 As Workbook, S1 As Worksheet
Dim X As Integer, Satır As Integer, Son_Satır As Long
Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String

Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçiniz...", 50, &H0)

If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
ElseIf Not Klasör Is Nothing Then
Kaynak_Klasör = Klasör.Items.Item.Path
Else
MsgBox "İşleme devam edebilmek için klasör seçimi yapmalısınız!" & Chr(10) & _
"İşleminiz iptal edilmiştir.", vbCritical
Exit Sub
End If

On Error Resume Next

Set K1 = ThisWorkbook
Set K2 = Workbooks.Add(1)
Dosya = Dir(Kaynak_Klasör & "\*.xls")
Satır = 2

Application.ScreenUpdating = False

Do
If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya") = 0 Then
DoEvents
Application.DisplayAlerts = False
Set K3 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
Application.DisplayAlerts = True
Set S1 = K3.Sheets(1)

Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
S1.Range("A2:AA" & Son_Satır).Copy _
K2.Sheets("Sayfa1").Range("A" & Satır)
Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2

K3.Close True
Dosya = Dir
Else
Dosya = Dir
End If
Loop While Dosya <> ""

K2.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
K2.SaveAs (Kaynak_Klasör & "\Dosya_" & Format(Now, "dd_mm_yyyy_hh_mm_ss"))
K2.Close True

Set K1 = Nothing
Set K2 = Nothing
Set K3 = Nothing

Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[ÖmerFaruk]

İlgili aralığa koyu renkli satırı giriniz.

Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
S1.Range("A2:AA" & Son_Satır).Copy _
K2.Sheets("Sayfa1").Range("A" & Satır)
K2.Sheets("Sayfa1").Range("AB" & Satır, "AB" & Sonsatır + Satır - 2) = Dosya
Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2

 

[ORHANGN]

ilginiz için teşekkür ederim ancak farkeden bişey olmadı. Fakat aşağıdaki makroyu buldum o istediğim sonucu verecek fakat ondada veri alınacak dosyaların ilk satırındaki sutunlardaki hücreler dolu olmadığı için hata veriyor acaba bu makroya ilişkin bir çözüm olabilir mi?

Sub KitaplariBirlestirBS()

Dim vaFiles As Variant
Dim wbkToCopy As Workbook
Dim ws As Worksheet
Dim wsa As Worksheet

ThisWorkbook.Activate

Set ws = Sayfa1

un = "Sayın " & Environ("UserName")

ms1 = MsgBox("Birden fazla dosyadan veri almak istiyor musunuz?", vbInformation + vbYesNo, un)
If ms1 = vbYes Then
ws.Range("A2:g" & Rows.Count).Clear

lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column


vaFiles = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
Title:="Select Files to Proceed", MultiSelect:=True)

With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

If IsArray(vaFiles) Then
For i = LBound(vaFiles) To UBound(vaFiles)
If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
GoTo skipfile:
End If

Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))

Set wsa = ActiveWorkbook.ActiveSheet

lra = wsa.Cells(Rows.Count, 1).End(xlUp).Row
lrc = wsa.Cells(1, Columns.Count).End(xlToLeft).Column

For c = 1 To lc
For ca = 1 To lrc
If wsa.Cells(1, ca) = ws.Cells(1, c) Then
cn = ca
Exit For
End If
Next ca
For r = 2 To lra
y = ws.Cells(Rows.Count, c).End(xlUp).Offset(1, 0).Row
If c <> lc Then
ws.Cells(y, c) = wsa.Cells(r, cn)
Else
ws.Cells(y, c) = Mid(ActiveWorkbook.Name, 1, InStr(1, _
ActiveWorkbook.Name, ".xls") - 1)
End If
y = y + 1
Next r
Next c
wbkToCopy.Close savechanges:=False
skipfile:
Next i
ws.Range("A1:g1").EntireColumn.AutoFit
ms5 = MsgBox("Verileriniz ana dosyaya aktarılmıştır", vbInformation, un)
Else
ms3 = MsgBox("Dosya seçmediniz!", vbExclamation, un)
End If
Else
ms2 = MsgBox("İşlemi İptal Ettiniz", vbInformation, un)
End If

With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub