A1 hücresine yazdığım veriyle aynı adda yeni sayfa oluşturmak

[cagdasozyurt]

Sayfa1 de A1 hücresine yazdığım adla yeni bir sayfa oluşturmak istiyorum. A2 hücresine başka bir veri yazınca aynı adla yeni bir sayfa oluştursun. Bu böyle 200 ya da 500 e kadar gitsin istiyorum. Birde yeni oluşturulan sayfalarda hep aynı şablon olsun istiyorum. Örneğin 2. sayfada zaten bir şablon oluşturmuşum o şablonun yeni açılan sayfaya kopyalanmasını istiyorum. Teşekkürler.

 

[cagdasozyurt]

Öyle bir soru sordum ki excelweb çaresiz kaldı

 

[Korhan Ayhan]

Merhaba,

Aslında forumda bu konuda bolca örnek var. Biraz arama yapmak gerekiyor.

Sizin için kurguladığım senaryo;

Dosyanızda Sayfa1 ve Şablon adında sayfalar oluşturun.
Şablon isimli sayfanızı istediğiniz gibi dizayn edin.
Sayfa1 isimli sayfanızın kod bölümüne aşağıdaki kodu uygulayın.

"A" sütununa veri girişi yaptıkça işlem yapılacaktır. Sayfa isimleri excelde 31 karakterle sınırlı olduğu için (2010 versiyonda durum böyle) bu şekilde sınırladım. Bu kurala dikkat ediniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Veri As Range, Sayfa As Worksheet, Mesaj As String, Say As Integer
  
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
  
    Application.ScreenUpdating = False
  
    For Each Veri In Intersect(Target, Range[URL='https://www.excel.web.tr/attachments/otomatik-sayfa-olusturma-xlsm.221524/?hash=f25f180b694201f8747210310035e695']Otomatik Sayfa Oluşturma.xlsm[/URL]("A:A"))
        If Veri.Value <> "" Then
            On Error Resume Next
            Set Sayfa = Nothing
            Set Sayfa = Sheets(Left(Veri.Value, 31))
            On Error GoTo 0
            If Sayfa Is Nothing Then
                Say = Say + 1
                Sheets("Şablon").Copy After:=Sheets(Sheets.Count)
                ActiveSheet.Name = Left(Veri.Value, 31)
            Else
                Mesaj = IIf(Mesaj = "", Veri.Value, Mesaj & vbLf & Veri.Value)
            End If
        End If
    Next
  
    Sheets("Sayfa1").Select
  
    Set Sayfa = Nothing
  
    Application.ScreenUpdating = True
  
    If Mesaj <> "" Then
        MsgBox "Aşağıdaki sayfalar zaten daha önce oluşturulmuş!" & vbLf & _
               "Bu sebeple işlem yapılamamıştır." & vbLf & vbLf & Mesaj, vbCritical
    Else
        If Say > 0 Then MsgBox IIf(Say = 1, "Sayfa", "Sayfalar") & " oluşturulmuştur.", vbInformation
    End If
End Sub

Ek olarak ihityacınız olur düşüncesi ile oluşturduğunuz sayfaları silmeniz icab ederse aşağıdaki kodu kullanabilirsiniz.

Option Explicit

Sub Sayfalari_Sil()
    Dim Onay As Byte, Sayfa As Worksheet, Say As Integer
  
    Onay = MsgBox("Sayfa1 ve Şablon isimli sayfaların dışındaki tüm sayfalar silinecektir!" & vbLf & _
                  "İşlemi onaylıyor musunuz?", vbCritical + vbYesNo + vbDefaultButton2)
                
    If Onay = vbNo Then
        MsgBox "Silme işlemi iptal edilmiştir.", vbInformation
        Exit Sub
    End If
  
    Application.DisplayAlerts = False
  
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> "Sayfa1" And Sayfa.Name <> "Şablon" Then
            Say = Say + 1
            Sayfa.Delete
        End If
    Next
  
    Application.DisplayAlerts = True

    If Say = 0 Then
        MsgBox "Silinecek sayfa bulunamadı!", vbExclamation
    Else
        MsgBox "Sayfa silme işlemi tamamlanmıştır.", vbInformation
    End If
End Sub