Sütunları sayfalarda toplama

[Serdarrk]

Merhaba,

Ekteki dosyadaki gibi dosyalarda her sayfanın A,B,C,Y ve Z sütunlarını alıp açılan yeni boş sayfalara sırasıyla ve bulunduğu sheetin ismiyle sıralanmasına ihtiyacım var. Yardımcı olursanız çok sevinirim.
http://www.dosya.tc/server12/g8gag7/01.02.1999-1.xls.html

 

[Serdarrk]

Aşağıdaki kod ile Y ve Z sütunlarını alıp sheetlerin adıyla birlikte sıralayabiliyor ancak Sayfa1 bitince Sayfa2 ye geçmek yerine hata veriyor. Bunu A,B,C,Y,Z sütunlarını art arda alıp yeni sayfalara sheetlerin adı ile yapıştıracak şekilde değiştirmek mümkün müdür?

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim lColumn As Long
    Dim ws As Worksheet
    For Each ws In Sheets
        lColumn = Sheets("Sayfa1").Cells(1, Columns.Count).End(xlToLeft).Column
        If ws.Name <> "Sayfa1" Then
            Sheets("Sayfa1").Cells(1, lColumn + 1).Resize(, 2) = ws.Name
            LastRow = ws.Range("Y" & ws.Rows.Count).End(xlUp).Row
            ws.Range("Y4:Z" & LastRow).Copy
            Sheets("Sayfa1").Cells(3, lColumn + 1).PasteSpecial xlPasteValues
        End If
    Next ws
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub