Çalışma kitabının ismi

[tahsinanarat]

aşağıdaki kodlarla kapalı dosyadaki çalışma sayfalarının 1 isimli sayfalarından dataları İCMAL çalışma kitabımın Sayfa1 ine alt alta alabiliyorum, burda herhangi bir sıkıntı yok.
Ben istiyorum ki bu kapalı çalışma sayfalarının isimlerini de en son sutunum olan AA sütununa yazsın istiyorum. Mevcut koda nasıl bir ilave kod yazmam gerekiyor. Teşekkürler

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False

    Dosya_Yolu = ThisWorkbook.Path
    Set S1 = Workbooks("İCMAL.xlsm").Sheets("Sayfa1")
    S1.Select
    Range("A2:Z" & Rows.Count).ClearContents
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files

    For Each Dosya In Klasör
        If InStr(Dosya.Name, ".xlsx") > 0 Then
            If Dosya.Name <> "İCMAL.xlsm" Then
                Workbooks.Open Filename:=Dosya
                With Sheets("1")
                    .Range("A2:z" & .Cells(65536, 1).End(3).Row).Copy S1.Cells(65536, 1).End(3).Offset(1)
                End With
                ActiveWorkbook.Close True
            End If
        End If
    Next

    Application.ScreenUpdating = True

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

 

[veyselemre]

Ortadaki bloğu aşağıdaki gibi deneyin, denenmemiştir.

                With Sheets("1")
                    Son = .Cells(65536, 1).End(3).Row
                    Set rng = s1.Cells(65536, 1).End(3).Offset(1)
                    .Range("A2:z" & Son).Copy rng
                    s1.Cells(rng.Row, "AA").Resize(Son - 1, 1).Value = dosya
                End With

 

[tahsinanarat]

veyselemre hocam denedim oldu, elinize sağlık. Çok teşekkür ederim.

 

[tahsinanarat]

Denedim oldu

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False

Dosya_Yolu = ThisWorkbook.Path
Set s1 = Workbooks("İCMAL.xlsm").Sheets("Sayfa1")
s1.Select
Range("A2:Z" & Rows.Count).ClearContents
Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files

For Each dosya In Klasör
If InStr(dosya.Name, ".xlsx") > 0 Then
If dosya.Name <> "İCMAL.xlsm" Then
Workbooks.Open Filename:=dosya
With Sheets("1")
Son = .Cells(65536, 1).End(3).Row
Set Rng = s1.Cells(65536, 1).End(3).Offset(1)
.Range("A2:z" & Son).Copy Rng
s1.Cells(Rng.Row, "AA").Resize(Son - 1, 1).Value = dosya.Name
End With

ActiveWorkbook.Close True
End If
End If
Next

Application.ScreenUpdating = True

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

veyseyemre hocam çok teşekkür ederim. denedim oldu, elinize sağlık

 

[tahsinanarat]

Sn. veyselevmre hocam, kapalı çalışma kitaplarının "1" isimli sayfalarından değil de tüm sayfalarından bilgi almak istersek nasıl bir ilave yapmalıyız.

 

[veyselemre]

Duzenleyin, denenmemiştir.

[COLOR="Red"]
   For Each sayfa In ActiveWorkbook.Sheets
        With sayfa[/COLOR]
            Son = .Cells(65536, 1).End(3).Row
            Set Rng = s1.Cells(65536, 1).End(3).Offset(1)
            .Range("A2:z" & Son).Copy Rng
            s1.Cells(Rng.Row, "AA").Resize(Son - 1, 1).Value = dosya
        End With
 [COLOR="red"]   Next sayfa[/COLOR]

 

[tahsinanarat]

Sn. veyselemre hocam elinize sağlık, mükemmel oldu.