Hücrede Yazan Verilere Göre Şablon Oluşturmak

[ozlem.solmaz]

Merhaba,

Ekteki dosyamda Veri sayfasında ki bulunan sayılara göre şablon oluşturmak istiyorum.

C3 hücresinde ki isim için ayrı bir şablon (örnek şablon koydum ) Sayfa adı ve Şablonda ki B3 hücresi aynı olmalıdır.

Örnek olarak ben sayfaları oluşturdum fakat liste uzayacağı için koda ihtiyacım vardır.

Yardımlarınız için teşekkürler...

 

[Muzaffer Ali]

Merhaba.
Veri sayfasının kod kısmına kopyalayıp çalıştırın.

Sub YeniSablon()
    Dim Bak As Long
    Application.ScreenUpdating = False
    For Bak = 3 To Worksheets("VERİ").Cells(Rows.Count, "C").End(xlUp).Row
        Worksheets("ÖRNEK_ŞABLON").Copy After:=Sheets(Worksheets.Count)
        With Worksheets("VERİ")
            ActiveSheet.Range("B3") = .Cells(Bak, "C")
            ActiveSheet.Name = .Cells(Bak, "C")
        End With
    Next
    Application.ScreenUpdating = True
End Sub

 

[ozlem.solmaz]

Merhaba,

Hocam hata veriyor kod. Veri kısmında ki yazan isimleri almıyor.

 

[Muzaffer Ali]

Kodu yeniledim. Tekrar deneyin.

 

[Necdet]

Merhaba,

Alternatif olsun.
Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub Sayfa_Kopyala_Ac()

Dim i   As Long
Dim lr  As Long
Dim adt As Integer
Dim syf As String

Application.ScreenUpdating = False

lr = Sayfa1.Cells(Rows.Count, "C").End(3).Row
'Aşağıdaki gibi de kullanılabilir
'lr = sheets("VERİ").Cells(Rows.Count, "C").End(3).Row
If lr < 3 Then lr = 3

For i = 3 To lr
    syf = Sayfa1.Cells(i, "C")
    If Not SayfaVarMi(syf) Then
        adt = adt + 1
        Sayfa2.Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = syf
        Range("B3") = syf
    End If
Next i

Sayfa1.Select
Application.ScreenUpdating = True

If adt = 0 Then
    MsgBox "Açılacak Yeni Sayfa Bulunmadı...."
Else
    MsgBox adt & " Adet Sayfa Açılmıştır..."
    
End If

End Sub

Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function