Makro ile listeye göre sayfa oluşturma ve sayfaya bir alt satırı kopyalama

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Üst başlıkları kopyalaması için "Sablon" isimli sayfa oluşturun. Oluşturulan bu sayfa kopyalanarak, a4 hücresine "A BLOK" sayfasındaki ilgili satır kopyalanacak ve sayfanın ismi abone no olarak atanacaktır.

Kod:
Sub sayfalaraAktar()

    Application.DisplayAlerts = False
    Dim i As Long
    Dim sayfalar
    ReDim sayfalar(1 To Sheets.Count)
    For i = 1 To Sheets.Count
        sayfalar(i) = Trim(Sheets(i).Name)
    Next i

    With Sheets("A BLOK")
        For i = 3 To .Cells(Rows.Count, 1).End(3).Row
            shf = Trim(.Cells(i, 1).Value)
            If Not IsError(Application.Match(shf, sayfalar, 0)) Then
                Sheets(shf).Delete
            End If

            Sheets("Sablon").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = shf
            .Cells(i, 1).Resize(, 7).Copy Cells(4, 1)
        Next i
        .Select
    End With

    Application.DisplayAlerts = True
End Sub
 

Ekli dosyalar

Katılım
3 Eylül 2011
Mesajlar
5
Excel Vers. ve Dili
2003 türkçe
hocam çok teşekkür ederim. 2 satır kopyalamak istersem ne yapmam gerekir kodun üzerinde yani 20001 abone kodu iki tane alt alta olacak şekilde.
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
hocam çok teşekkür ederim. 2 satır kopyalamak istersem ne yapmam gerekir kodun üzerinde yani 20001 abone kodu iki tane alt alta olacak şekilde.
Kod:
Sub sayfalaraAktar()

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Dim i As Long, sat As Long
    Dim sayfalar
    
    ReDim sayfalar(1 To Sheets.Count)
    
    For i = 1 To Sheets.Count
        sayfalar(i) = Trim(Sheets(i).Name)
    Next i
    Sheets("A BLOK").Copy After:=Sheets(Sheets.Count)

    With ActiveSheet
        While .Cells(3, 1).Value <> ""
            shf = Trim(.Cells(3, 1).Value)
            If Not IsError(Application.Match(shf, sayfalar, 0)) Then
                Sheets(shf).Delete
            End If
            Sheets("Sablon").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = shf
            sat = 4
            For i = 3 To .Cells(Rows.Count, 1).End(3).Row
                If Trim(.Cells(i, 1).Value) = shf Then
                    .Cells(i, 1).Resize(, 7).Copy Cells(sat, 1)
                    sat = sat + 1
                    .Rows(i).Delete
                End If
            Next i
        Wend
        .Select
        .Delete
    End With
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Son düzenleme:
Katılım
3 Eylül 2011
Mesajlar
5
Excel Vers. ve Dili
2003 türkçe
çok teşekkür ediyorum. Birazda kendim şablonu değiştirerek halletim. Şimdi ilgi ve alakanız için hemen altın üyelik satın alacağım.
 
Üst