Makro ile toplu sayfa kopyalama

[BostonExcel]

Merhaba;
Sayfa1'de aşağıdaki bir listede B2'den başlayan isimlere göre, Sayfa2'yi kopyalacak bir makro yapmak istiyorum. O listede 150 tane isim olacak. Yani tek tek açmak istemiyorum, bu listedeki isimlerde örnek sayfayı (Sayfa2) kopyalarak adını sırası ile bu yapsın istiyorum. (Örnek makrolar buldum, ancak yeni sayfa açılabiliyor, kopyalama yapamıyorum! Çünkü Sayfa2'de bir şablon var, onu kullanmam gerekiyor1)

Sıra No Firma Listesi
1 ABC TİCARET
2 Z İTHALAT
3 KARA MARKET

Bu konuda yardımcı olabilir misiniz?

 

[Korhan Ayhan]

Merhaba,

Deneyiniz.

Firma sayfalarını ŞABLON sayfasını kopyalayarak oluşturur ve sayfalara link verir. Excel sayfa ismi olarak belli bir karaktere (31 karakter) kadar izin verir. Bu sebeple çok uzun firma isimlerinde sayfaların ismi kısalacaktır.

Not : Kod her seferinde önce var olan firma sayfalarını siler sonra yeniden oluşturur. Bu duruma dikkat ederek kullanınız.

Option Explicit

Sub Sheets_Copy()
    Dim WS As Worksheet, S1 As Worksheet, S2 As Worksheet
    Dim S3 As Worksheet, S4 As Worksheet
    Dim Son As Long, Firma As Variant, X As Integer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    Son = WorksheetFunction.Max(3, Son)
    
    S1.Range("B:B").Hyperlinks.Delete
    
    Firma = S1.Range("B2:B" & Son).Value
    
    Application.DisplayAlerts = False
    For Each WS In ThisWorkbook.Worksheets
        If WS.Name <> S1.Name And WS.Name <> S2.Name Then WS.Delete
    Next
    Application.DisplayAlerts = True
    
    For X = LBound(Firma, 1) To UBound(Firma, 1)
        If Firma(X, 1) <> "" Then
            On Error Resume Next
            Set S3 = Nothing
            Set S3 = Sheets(Firma(X, 1))
            On Error GoTo 0
            If S3 Is Nothing Then
                S2.Copy After:=Sheets(Sheets.Count)
                Set S4 = ActiveSheet
                S4.Name = Left(Firma(X, 1), 31)
                S4.Hyperlinks.Add Anchor:=S1.Cells(X + 1, 2), Address:="", SubAddress:="'" & Firma(X, 1) & "'!A1", TextToDisplay:=Firma(X, 1)
            End If
        End If
    Next
    
    S1.Select
    
    Set WS = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Firma şablonları oluşturulmuştur.", vbInformation
End Sub

 

[BostonExcel]

Korhan bey 2 yıl önce sormuşum soruyu, ama o zaman mesajınızı görmemişim, bugün tekrar ihtiyaç duyunca yazacaktım foruma, ancak mesajınızı şimdi gördüm. Kodunuzu kullandım, çalıştı, çok teşekkür ederim. Allah razı olsun.