DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub SAYFALARI_OLUŞTUR()
Dim S1 As Worksheet, S2 As Worksheet
Dim S3 As Worksheet, X As Long, Son As Long
Application.ScreenUpdating = False
Set S1 = Sheets("ANA MENÜ")
Set S2 = Sheets("ŞABLON")
Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
For X = 2 To Son
Set S3 = Nothing
On Error Resume Next
Set S3 = Sheets(S1.Cells(X, 2).Value)
On Error GoTo 0
If S3 Is Nothing Then
S2.Copy , Sheets(ThisWorkbook.Worksheets.Count)
ActiveSheet.Name = S1.Cells(X, 2).Value
S1.Select
End If
Next
Set S1 = Nothing
Set S2 = Nothing
Set S3 = Nothing
Application.ScreenUpdating = True
MsgBox "Sayfalar oluşturulmuştur.", vbInformation
End Sub
Sub SAYFALARI_SİL()
Dim Sayfa As Worksheet, Silinmeyecek_Sayfalar(), Kontrol As Boolean
Application.ScreenUpdating = False
Silinmeyecek_Sayfalar = Array("ANA MENÜ", "ŞABLON")
Application.DisplayAlerts = False
For Each Sayfa In ThisWorkbook.Worksheets
For X = 0 To UBound(Silinmeyecek_Sayfalar)
If Silinmeyecek_Sayfalar(X) = Sayfa.Name Then
Kontrol = True
Exit For
End If
Next
If Kontrol = False Then
Sayfa.Delete
Else
Kontrol = False
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Sayfalar silinmiştir.", vbInformation
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C2")) Is Nothing Then Exit Sub
For i = 1 To Worksheets.Count
If Worksheets(i).Name = Worksheets("Ana menu").Range("C2").Value Then
MsgBox "Bu isimde bir sayfa bulundu"
Exit Sub
End If
Next i
Worksheets.Add After:=Sheets(Worksheets.Count)
ActiveSheet.Name = Worksheets("Ana menu").Range("C2").Value
End Sub
Merhaba,
Dosyanızda ANA MENÜ ve ŞABLON isminde iki sayfa hazırlayın.
ANA MENÜ sayfasının "B" sütunundaki isimlere göre şablon sayfasının kopyası oluşacak şekilde kodu hazırladım. Deneyebilirsiniz.
Ek olarak oluşan sayfaları silebilmeniz içinde bir kod hazırladım.
Kod:Sub SAYFALARI_OLUŞTUR() Dim S1 As Worksheet, S2 As Worksheet Dim S3 As Worksheet, X As Long, Son As Long Application.ScreenUpdating = False Set S1 = Sheets("ANA MENÜ") Set S2 = Sheets("ŞABLON") Son = S1.Cells(S1.Rows.Count, 2).End(3).Row For X = 2 To Son Set S3 = Nothing On Error Resume Next Set S3 = Sheets(S1.Cells(X, 2).Value) On Error GoTo 0 If S3 Is Nothing Then S2.Copy , Sheets(ThisWorkbook.Worksheets.Count) ActiveSheet.Name = S1.Cells(X, 2).Value S1.Select End If Next Set S1 = Nothing Set S2 = Nothing Set S3 = Nothing Application.ScreenUpdating = True MsgBox "Sayfalar oluşturulmuştur.", vbInformation End Sub Sub SAYFALARI_SİL() Dim Sayfa As Worksheet, Silinmeyecek_Sayfalar(), Kontrol As Boolean Application.ScreenUpdating = False Silinmeyecek_Sayfalar = Array("ANA MENÜ", "ŞABLON") Application.DisplayAlerts = False For Each Sayfa In ThisWorkbook.Worksheets For X = 0 To UBound(Silinmeyecek_Sayfalar) If Silinmeyecek_Sayfalar(X) = Sayfa.Name Then Kontrol = True Exit For End If Next If Kontrol = False Then Sayfa.Delete Else Kontrol = False End If Next Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "Sayfalar silinmiştir.", vbInformation End Sub
Rica ederim.Dönüş yaptığınız için teşekkür ederim.Range("B1") = ActiveSheet.Name
Ben bunu denemiştim ama kodun sonuna koymuştum sizin dediğiniz yerde denedim oldu. Çok teşekkür ederim.