Soru Çizelgemdeki isimler ile sekmeler oluşturma ve tüm sekmelere buton yardımıyla verileri gönderme

[Sebahattinnn]

Konum oluşturmak istediğim tebliğ belgesi ile alakalıdır. Yaklaşık 100 kişilik listemi manuel hazırlamaktayım. Proğramla olabileceğini buldum ancak uygun kod bulamadım. Bir isim listem mevcut ve hizalarında x işaretlerim var. x işaretleri olanlara buton yardımıyla isimleriyle sekmeler oluşturmak istiyorum. Sekmeleri oluştururken başlık alanım var onu da yapıştırmasını istiyorum. Sekmeler oluşturulup, başlık atılırsa şayet yine buton yardımıyla her sekmeye tebliğ konularımı sırasıyla ekleyebilirmiyiz acaba? Detaylı anlatımım excel dosyamda mevcuttur. Şimdiden emekleriniz için teşekkür ederim.

 

[Sebahattinnn]

Korhan Hocamın hazırladığı bir kodu buldum. İsimlerimi A sütununa taşırsam isimlerle sekme oluşturabilir. Sekme oluşturma formülü tamama yakın gibi, kendime ayarlamassam kodu. Bununla beraber birkaç sorumu daha bu koda ekleme yapabilirmiyiz acaba?

Option Explicit

Sub Sayfalara_Aktar()
    Dim Onay As Byte, Sayfa As Worksheet, S1 As Worksheet
    Dim Dizi As Object, Veri As Variant, Son As Long
    Dim X As Long, Malzeme As Variant, Satir As Long
    
    Onay = MsgBox("Eski bilgilerin bulunduğu sayfaları silmek ister misiniz?" & Chr(10) & Chr(10) & _
           "EVET : Sayfaları silerek veriler yeni eklenen sayfalara aktarılır." & Chr(10) & _
           "HAYIR : Var olan sayfaların altına yeni veriler eklenerek işlem yapılır.", vbCritical + vbYesNo + vbDefaultButton2)
        
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    If Onay = vbYes Then
        Application.DisplayAlerts = False
        For Each Sayfa In ThisWorkbook.Worksheets
            If Sayfa.Name <> "Ana Sayfa" Then Sayfa.Delete
        Next
        Application.DisplayAlerts = True
    End If
    
    Set S1 = Sheets("Ana Sayfa")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:A" & Son).Value
    
    For X = 1 To UBound(Veri, 1)
        Dizi(Veri(X, 1)) = 1
    Next
    
    For Each Malzeme In Dizi.Keys
        Set Sayfa = Nothing
        On Error Resume Next
        Set Sayfa = Sheets(CStr(Malzeme))
        On Error GoTo 0
        If Sayfa Is Nothing Then
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = Malzeme
            S1.Range("A1:E" & S1.Rows.Count).AutoFilter 1, Malzeme
            S1.Range("A1").CurrentRegion.Copy ActiveSheet.Range("A1")
            ActiveSheet.Cells.EntireColumn.AutoFit
        Else
            Satir = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row + 1
            S1.Range("A1:E" & S1.Rows.Count).AutoFilter 1, Malzeme
            Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                S1.Range("A2:E" & Son).Copy Sayfa.Range("A" & Satir)
                ActiveSheet.Cells.EntireColumn.AutoFit
            End If
        End If
    Next

    On Error Resume Next
    S1.Select
    S1.ShowAllData
    On Error GoTo 0
    
    Onay = MsgBox("Aktarılan verileri ana sayfadan silmek ister misiniz?", vbCritical + vbYesNo + vbDefaultButton2)
    If Onay = vbYes Then
        S1.Range("A2:E" & S1.Rows.Count).ClearContents
    End If
    
    Set Sayfa = Nothing
    Set S1 = Nothing
    Set Dizi = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub
Function Sayfa(SAYFAADI As String) As Boolean
    On Error Resume Next
    Sayfa = CBool(Len(Worksheets(SAYFAADI).Name) > 0)
End Function

 

[Sebahattinnn]

Değerli excel üstadlarim, yardımcı olabilirmi acaba?