Birleştirilen dosyadaki sayfanın adı

[Kumpasta]

Merhaba.
Altta vereceğim kodlara bir ekleme yapabilirmisiniz?
Bir klasördeki tüm excelleri alt alta 1. stündan ve 8. satırdan itibaren güzel bir şekilde kopyalıyor.
kopyaladığı verileri 2. sütundan itibaren kopyalasa ve 1. sütuna da ilgili dosyanın içindeki excellerin sayfa adlarını yazsa gibi bir isteği bulunmakta.
Aşağıda kırmızı ile işaretlediğim alanın kodda ki karşılığını talep etmekteyim.
İlgili düzenleme de yardımcı olabilir misiniz?

Sub BİRLEŞTİR_KISA()
    Dim AktifDosya As Workbook
    Dim Dosya As Workbook
    Dim DosyaAdi
     
    Set AktifDosya = ActiveWorkbook
 
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Title = "Birleştirilecek Dosyaları Seçin"
     
        If .Show Then
            For Each DosyaAdi In .SelectedItems
                Set Dosya = Workbooks.Open(DosyaAdi)
             
                Dosya.Worksheets(1).UsedRange.Copy AktifDosya.Worksheets(1).Range("A65536").End(xlUp)(8, 1)
             
                Dosya.Close False
                Set Dosya = Nothing
            Next
        End If
    End With
 
    Set AktifDosya = Nothing
End Sub

 

[feridici_genc]

Konu biraz komplike bana göre

 

[Kumpasta]

konu günceldir

 

[Kumpasta]

şu şekilde yapmaya çalıştım fakat olmadı

Dosya.Worksheets(1).Sheets.Name AktifDosya.Worksheets(2).Range("A65536").End(xlUp)(8, 1)

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Merge_Data_Files()
    Dim K1 As Workbook, K2 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Dosya As Variant, Say As Long, Veri_Adedi As Long
     
    Set K1 = ActiveWorkbook
    Set S1 = K1.Sheets("Fişler")
    
    S1.Cells.Delete
     
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Title = "Birleştirilecek Dosyaları Seçiniz..."
     
        If .Show Then
            Application.ScreenUpdating = False
            For Each Dosya In .SelectedItems
                Set K2 = GetObject(Dosya)
                Set S2 = K2.Sheets(1)
                
                Say = S2.UsedRange.Rows.Count
                Veri_Adedi = Veri_Adedi + Say
                
                S2.UsedRange.Copy S1.Cells(S1.Rows.Count, "A").End(xlUp)(8, 2)
                S1.Cells(S1.Rows.Count, "A").End(3)(8, 1).Resize(Say) = S2.Name
                
                K2.Close False
                
                Set S2 = Nothing
                Set K2 = Nothing
            Next
            Application.ScreenUpdating = True
        Else
            MsgBox "Dosya seçimi yapmadığınız için işleminiz iptal edilmiştir.", vbExclamation
            GoTo 10
        End If
    End With
 
    MsgBox "Seçtiğiniz dosyalardaki veriler aktif dosyanıza aktarılarak birleştirilmiştir." & vbCrLf & vbCrLf & _
           "Birleştirilen toplam veri satır adedi ; " & FormatNumber(Veri_Adedi, 0), vbInformation

10  Set S1 = Nothing
    Set K1 = Nothing
End Sub

 

[Kumpasta]

Teşekkür ederim bu saatte dönüş için.
sırayla işlemi yaparken 1. sütundaki isimleri diğer dosyaya geçtiğinde 1 hücre kaydırıp altından başlıyor. dosya başına 1 hüce.
aynı hizada neden gitmiyor acaba

 

[Korhan Ayhan]

Paylaştığınız kodu 3 adet 5 satırlık veri içeren örnek dosyalar üzerinde deneyerek kodu sizinle paylaştım. Yaptığım denemede bende satır kayması olmadı.

 

[Kumpasta]

kendi dosyalarımdan 3 örnek paylaşıyorum test edebilirmisiniz sizde?

 

[Korhan Ayhan]

Paylaştığınız dosyalara göre önerdiğim kodu revize ettim. Tekrar deneyiniz.

 

[Kumpasta]

Teşekkür ederim elinize sağlık.

 

[Korhan Ayhan]

Üstte ki mesajımda ki önerdiğim kodu biraz daha verimli hale getirdim. Son halini kullanınız.