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
2,682
Excel Vers. ve Dili
Excel 2003-tr
Ü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
3
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
2,682
Excel Vers. ve Dili
Excel 2003-tr
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
3
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