Function create_calendrier(année, Mois)
Dim i As Long, L As Long, col As Long, lig As Long, nbjour As Long, difeuro As Long, j, k, Jférié, Jfériéstring, coulférié, paques, pentecote, lunpentecote, ascension, Jfête, Jfêtestring
Dim a, M
Dim vdate As Date
Dim zoneA As Range, zoneB As Range, zoneC As Range
Dim cell As Range
Application.ScreenUpdating = False
' Calcul des fêtes mobiles
paques = Format(CDate(((Round(DateSerial(année, 4, (234 - 11 * (année Mod 19)) Mod 30) / 7, 0) * 7) - 6)), "dd/mm/") ' Calcul du lundi de Pâques
ascension = Format(CDate(paques & année) + 39, "dd/mm/") ' Calcul du jeudi de l'Ascension
pentecote = Format(CDate(paques & année) + 49, "dd/mm/") ' Calcul du dimanche de Pentecôte
lunpentecote = Format(CDate(paques & année) + 50, "dd/mm/") ' Calcul du lundi de Pentecôte
' Liste des jours fériés
Jférié = Array("25/12/", "01/01/", "14/02/", paques, ascension, pentecote, lunpentecote, IIf(année > 1973, "01/05/", ""), IIf(année > 1944, "08/05/", ""), "14/07/", "15/08/", "01/11/", "11/11/")
Jfériéstring = Array("NOËL", "Jour de l'an", "Saint-Valentin", "Pâques", "Ascension", "Pentecôte", "Lundi de Pentecôte", IIf(année > 1973, "Fête du travail", ""), IIf(année > 1944, "Victoire 1945", ""), "Fête nationale", "Assomption", "Toussaint", "Armistice 1918")
' Nombre de jours dans le mois
nbjour = Day(DateSerial(année, Mois + 1, 0))
col = Weekday(DateSerial(année, Mois, 1), vbMonday) + 1 ' Index du jour de la semaine
If Weekday(DateSerial(année, 1, 1), vbMonday) > 4 Then difeuro = 1
lig = Range("Calendrier").row + 1 ' Ligne de départ pour le calendrier
' Définir les plages de la Feuille B pour les zones A, B et C
With Worksheets("Vacances")
Set zoneA = .Range("A2:A" & .cells(.rows.Count, "A").End(xlUp).row)
Set zoneB = .Range("B2:B" & .cells(.rows.Count, "B").End(xlUp).row)
Set zoneC = .Range("C2:C" & .cells(.rows.Count, "C").End(xlUp).row)
End With
' Génération du calendrier
With Worksheets("Calendrier")
.Range("Calendrier").ClearContents
.Range("Calendrier").Offset(1, 1).Interior.Color = xlNone
.Range("Calendrier").Offset(1, 1).ClearComments
.Range("B17:B18").ClearContents
.Range("B20").ClearContents
.Range("D17:E17").ClearContents
.Range("G17").ClearContents
For i = 1 To nbjour
If col = 9 Then lig = lig + 5: col = 2
.cells(lig, col).Interior.Color = 15395562
.cells(lig, col) = i
' Calcul de la date actuelle
a = Year(Range("B1")): M = Month(Range("B1")): j = i
vdate = DateSerial(a, M, j)
' Vérification des zones (A, B, C) et application de couleurs
For Each cell In zoneA
If cell.Value = vdate Then
.cells(lig + 2, col).Interior.Color = RGB(255, 200, 200) ' Rouge clair pour zone A
Exit For
End If
Next cell
For Each cell In zoneB
If cell.Value = vdate Then
.cells(lig + 3, col).Interior.Color = RGB(200, 255, 200) ' Vert clair pour zone B
Exit For
End If
Next cell
For Each cell In zoneC
If cell.Value = vdate Then
.cells(lig + 4, col).Interior.Color = RGB(200, 200, 255) ' Bleu clair pour zone C
Exit For
End If
Next cell
' Vérification des jours fériés
For j = 0 To UBound(Jférié)
If CDate(Jférié(j) & année) = DateSerial(année, Mois, i) Then
.cells(lig + 1, col).Interior.Color = 10092441 ' Couleur pour jour férié
.cells(lig + 1, col) = Jfériéstring(j)
End If
Next j
' Coloration du jour actuel
If Date = DateSerial(année, Mois, i) Then
.cells(lig, col).Interior.Color = 65280
End If
col = col + 1
Next i
' Ajout du titre et des jours de la semaine
.Range("B1") = UCase(Format(DateSerial(année, Mois, 1), "mmmm yyyy"))
.Range("A2").Resize(1, 8) = Array("Semaine", "Lundi", "Mardi", "Mercredi", "Jeudi", "Vendredi", "Samedi", "Dimanche")
End With
Algorithme année, Mois, 12
Call recup_phase
End Function
