Automatiser une création de 52 feuilles avec une incrémentation de dates

Bonjour Madame, Monsieur,

Je vous contacte suite à un problème qui se pose pour moi.

Je souhaite créer un planning avec 52 semaines (jours ouvrés), en incrémentant une date par rapport à la feuille précédente.

Ex : Feuille 1 (nommée S1) commence le 02/01/2023 et finit le 06/01/2023.

La feuille 2 (nommée S2) doit commencer avec le dernier jour noté (soit le 06/01/2023) + 3 (Samedi, dimanche, lundi) afin d'avoir le premier jour ouvré de la semaine suivante.

Mon souci, c'est de pouvoir d'automatiser ça pour les 52 semaines. Je suis un vrai novice sur excel.

Cela fait quelques jours que je cherche des réponses. Sans succès.

Pourriez-vous m'aider, svp ?

Cordialement,

JuanGuy.

Bonjour,

Par exemple :

Option Explicit

Sub TestCreationCalendriersHebdomadaires()

Dim I As Integer

    For I = 1 To 52
        If PresenceOnglet(I) = False Then
           CreationCalendriersHebdomadaires 2023, I
        End If
    Next I

End Sub

Sub CreationCalendriersHebdomadaires(ByVal AnneeCalendrier As Integer, ByVal SemaineACreer As Integer)

Dim ShSemaine As Worksheet
Dim I As Integer, SemaineEncours As Integer, LigneEncours As Integer
Dim DateEncours As Date

    SemaineEncours = SemaineACreer
    Set ShSemaine = Sheets.Add(after:=Sheets(Sheets.Count))
    ShSemaine.Name = "S" & SemaineACreer

    With ShSemaine
         .Cells(10, 1) = "Dates"
         LigneEncours = 11
         For DateEncours = DateSerial(AnneeCalendrier, 1, 1) To DateSerial(AnneeCalendrier, 12, 31)
             If WorksheetFunction.IsoWeekNum(DateEncours) = SemaineEncours Then
                Select Case WorksheetFunction.Weekday(DateEncours, 2)
                       Case 1 To 5
                         Debug.Print DateEncours
                            .Cells(LigneEncours, 1).Value = Format(DateEncours, "dd/mm/yyyy dddd")
                            LigneEncours = LigneEncours + 1
                            If LigneEncours = 5 Then Exit For
              End Select
            End If
        Next DateEncours
    End With

    Set ShSemaine = Nothing

End Sub

Function PresenceOnglet(ByVal NumeroSemaine As Integer) As Boolean

Dim I As Integer

    PresenceOnglet = False
    For I = 1 To Sheets.Count
        If Sheets(I).Name = "S" & NumeroSemaine Then
           PresenceOnglet = True
           Exit Function
        End If
    Next I

End Function

Parfait.

Je n'ai pas compris le code, mais je vois que ça fonctionne bien.

Je vais regarder les cours pour pouvoir utiliser au mieux la formule avec mon fichier de base.

Les cellules qu'il y a dans votre programme ne correspondent pas au miennes (normal, je ne vous ai rien donné ^^'), je dois donc les modifier pour les adapter au mien.

Merci pour tout :)

Cordialement,

JuanGuy

Bonjour,
Une autre approche.
Cdlt.

Option Explicit

Sub CreateWeeklyData()
Dim wb As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim iYear As Integer, iWeeks As Integer, iWeek As Integer
Dim dtm As Date
Dim i As Integer

    With Application
        '.DisplayAlerts = False
        .ScreenUpdating = False
    End With

    Set wb = ActiveWorkbook

    'For Each ws In wb.Worksheets
        'Select Case ws.Name
            'Case "Accueil", "Modèle":
            'Case Else: ws.Delete
        'End Select
    'Next ws

    'Application.DisplayAlerts = True

    iYear = Range("_année")
    'nombre de semaines dans l'annee (52 ou 53)
    iWeeks = WorksheetFunction.IsoWeekNum(DateSerial(iYear, 12, 28))

    Set ws = wb.Worksheets("Modèle")

    For iWeek = 1 To iWeeks
        dtm = DateSerial(iYear, 1, -2) - Weekday(DateSerial(iYear, 1, 3)) + 7 * iWeek
        ws.Copy after:=wb.Worksheets(Worksheets.Count)
        Set ws2 = ActiveSheet
        ws2.Name = WorksheetFunction.Text(iWeek, """S""00")
        ws2.Cells(2, 4).Value = ws2.Name
        For i = 0 To 4
            ws2.Cells(4, 4).Offset(, i).Value = dtm + i
        Next i
    Next iWeek

End Sub