Otomatik Sayfa Oluşturma ve dosya yedekleme

[arrow3441]

Merhaba hepinize iyi seneler diliyorum. Ekteki dosyada Veri sayfasında A2 hücresine ay başlangıç tarihi yazınca 1 aylık tarihleri alt alta yazması ve otomatik Şablon sayfasının kopyası alarak sayfaları oluşturması hücredeki tarihlere bakarak isimlendirmesi .Eğer aynı isme ait sayfalar varsa hiçbirşey yapmasın yada uyarsın
2. yapmak istediğim ise dosyayı hücrede tarihdeki aya bakarak isimlendirip yedekleyip sonra sayfaları silmesi Veri ve Şablon sayfası hariç olarak

 

[arrow3441]

?

 

[ÖmerFaruk]

A2 hücresine
10.10.2022 yazınca

alt alta hangi tarihler oluşacak?
Limit nedir? Bugün mü? Yoksa 31 adet mavi renge sahip hücre var. A32 ye kadar. 31 adet tarih mi oluşacak?

 

[arrow3441]

31 adet tarih oluşucak hocam . Kaç gün çekiyorsa o ay ona göre oluşması gerekiyor. Ay başlangıcı yazıcam hocam 01.01.2023 gibi

 

[arrow3441]

Ömerfaruk hocam bakabildinizmi

 

[ÖmerFaruk]

Aşağıdaki kodları boş bir modül içine kopyalayıp butonlarınıza atayabilirsiniz.
(Çalıştırmadan önce dosyanızın yedeğini alın)

Sub TarihOnayla()
    Dim Sh1 As Worksheet, Sh2 As Worksheet, i As Integer
    Set Sh1 = Worksheets("Veri")
    Application.ScreenUpdating = False
    Sh1.Range("A3:B32").ClearContents
    If Sh1.Range("A2") = 0 Or Not IsDate(Sh1.Range("A2")) Then Exit Sub
    On Error Resume Next
    ReDim Liste(1 To 31)
    For i = 1 To 31
        Sh1.Range("A" & i + 1) = DateAdd("m", i - 1, Sh1.Range("A2"))
        Liste(i) = Format(Sh1.Range("A" & i + 1), "yyyy-mm")
        Set Sh2 = Worksheets(Liste(i))
        If Sh2 Is Nothing Then
            Worksheets("Şablon").Copy After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Liste(i)
        End If
        Set Sh2 = Nothing
    Next i
    For i = 31 To 1 Step -1
        Worksheets(Liste(i)).Move After:=Worksheets("Şablon")
    Next i
    On Error GoTo 0
    Sh1.Activate
    Sh1.Range("A2").Activate
    Application.ScreenUpdating = True
    Set Sh1 = Nothing: Erase Liste: i = Empty
End Sub

Sub Yedekle()
    Dim Sh As Worksheet
    If WorksheetFunction.CountA(Range("A2:A32")) <> 31 Then MsgBox "A2:A32 arasında sayfa isimleri eksik": Exit Sub
    On Error Resume Next
    For i = 1 To 31
        Set Sh = Worksheets(Format(Range("A" & i + 1), "yyyy-mm"))
        If Sh Is Nothing Then MsgBox Format(Range("A" & i + 1), "yyyy-mm") & " Sayfası eksik": Exit Sub
        Set Sh = Nothing
    Next i
     If Sheets.Count > 33 Then MsgBox "Listediki 31 aydan daha fazla sayfa var": Exit Sub
    Application.DisplayAlerts = False
    Worksheets("Veri").Delete
    Worksheets("Şablon").Delete
    ThisWorkbook.SaveAs "YedekDosya-" & Format(Range("A2"), "yyyy-mm")
    On Error GoTo 0
    Application.DisplayAlerts = True
End Sub

 

[arrow3441]

Deneyip bilgi veriyorum hemen hocam çok teşekkür ederim

 

[arrow3441]

Hocam A2 01.01.2022 alttaki şekilde verdi . 02.01.2022,03.01.2022 şeklinde gitmesi gerekiyordu ama hocam birde şubat da 28 gün çekiyor ona göre oluşturması gerekiyor

01.02.2022
01.03.2022
01.04.2022
01.05.2022
01.06.2022
01.07.2022
01.08.2022
01.09.2022
01.10.2022
01.11.2022
01.12.2022
01.01.2023
01.02.2023
01.03.2023
01.04.2023
01.05.2023
01.06.2023
01.07.2023
01.08.2023
01.09.2023
01.10.2023
01.11.2023
01.12.2023
01.01.2024
01.02.2024
01.03.2024
01.04.2024
01.05.2024
01.06.2024
01.07.2024

 

[Tevfik_Kursun]

Merhaba Arkadaşım,
İnceleyiniz ...
İyi çalışmalar

 

[Tevfik_Kursun]

Merhaba Arkadaşım,
İnceleyiniz ... (Sanki biraz daha hızlı)
İyi çalışmalar

 

[arrow3441]

@Tevfik_Kursun hocam çok teşekkür ederim gayet güzel çalışıyor elinize sağlık

 

[Tevfik_Kursun]

Rica ederim
İyi çalışmalar

 

[arrow3441]

Hocam 2 dosyadaki kodlar aynı ama hız bakımından 2 side aynı gibi

 

[Tevfik_Kursun]

İkinci dosya işlemleri göstermiyor. Sayfa çoğaltma işlemi daha fazla olsa aradaki farkı daha rahat görürdünüz.
Kolay gelsin

 

[arrow3441]

Teşekkür ederim

 

[Tevfik_Kursun]

@arrow3441
Sayın Arrow3441,
Kusura bakma arkadaşım. Bu dosyaya bakın lütfen
İyi çalışmalar

 

[arrow3441]

Merhaba bakıyorm hemen

 

[arrow3441]

Evet hocam bu çok hızlı çok daha iyi elinize sağlık tekrardan

 

[Tevfik_Kursun]

Yanlışlıkla aynı dosyayı tekrar göndermişim. Kusura bakma lütfen.
İyi çalışmalar

 

[arrow3441]

Hocam k.bakmayın lütfen birşeyi atlamışım oluşturulan sayfaların korunması gerekmektedir. Düzenleme yapabilirmsiniz buna göre