Const SOURCE As String = "CHOIX ANNEE"
Sub CalendrierAnnee()
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim R As Range
Dim C As Range
Dim Annee As Long
Dim i&
Dim A$
Dim var
Dim mois
mois = Array("Janvier", "Février", "Mars", "Avril", "Mai", "Juin", "Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre")
Set S1 = Sheets(SOURCE)
Annee = S1.[a1]
For i& = 1 To ActiveWorkbook.Sheets.Count
If ActiveWorkbook.Sheets(i&).Name = Annee Then
MsgBox "La feuille ''" & Annee & "'' existe déjà"
Exit Sub
End If
Next i&
S1.Copy After:=Sheets(Sheets.Count)
Set S2 = ActiveSheet
S2.Name = Annee
S2.Cells.Copy
With S2.[a1]
.PasteSpecial Paste:=xlPasteValues
With .Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator:=xlBetween
End With
.Select
.Value = Chr(160) & Annee
End With
On Error Resume Next
S2.Shapes("CommandButton1").Cut
On Error GoTo 0
With S2.Cells
.FormatConditions.Delete
.NumberFormat = "ddd dd"
.Interior.ColorIndex = xlNone
End With
S2.Rows(2).Insert
S2.Range("a2:l2") = mois
Set R = S2.[a1].CurrentRegion
For i& = R.Columns.Count To 2 Step -1
S2.Columns(i&).Insert Shift:=xlToRight
Next i&
With S2.Range("a1:x1")
.HorizontalAlignment = xlCenter
.MergeCells = True
.Font.Size = 20
End With
Set R = S2.Range("a2:b2")
For i& = 1 To 12
With R
.HorizontalAlignment = xlCenter
.MergeCells = True
.Interior.ColorIndex = 36 - (i& Mod 2)
With .Font
.Size = 10
.Bold = True
End With
End With
Set R = R.Offset(0, 1).Resize(1, 2)
Next i&
With S2.Columns
.ColumnWidth = 11
.AutoFit
End With
Set R = S2.[a1].CurrentRegion
For Each C In R
If C.Address <> "$A$1" Then
A$ = Format(C, "ddd")
If A$ = "sam." Or A$ = "dim." Then
C.Interior.ColorIndex = 6
End If
End If
Next C
'--- Traitement des jours fériés ---
var = JoursFeries(Annee)
For Each C In R
For i& = 1 To UBound(var, 1)
If C = var(i&, 2) Then
If C.Interior.ColorIndex = xlNone Then C.Interior.ColorIndex = 45
With C.Offset(0, 1)
.Interior.ColorIndex = 45
.Value = var(i&, 1)
End With
Exit For
End If
Next i&
Next C
Application.CutCopyMode = False
End Sub
Public Function JoursFeries(ByVal Annee As Integer) As Variant
Dim T(1 To 12, 1 To 2)
T(1, 1) = "Jour de l'An"
T(1, 2) = CDate("1/1/" & Annee)
'--- Algorithme jour de Pâques ---
Dim nE As Integer
Dim nH As Integer
Dim nK As Integer
Dim nP As Integer
Dim nQ As Integer
Dim nI As Integer
Dim nJ As Integer
Dim nGolden As Integer
Dim nCentury As Integer
Dim nCenturyQ As Integer
Dim Paques As Date
nGolden = Annee Mod 19
nCentury = Annee \ 100
nCenturyQ = nCentury \ 4
nE = (8 * nCentury + 13) \ 25
nH = (19 * nGolden + nCentury - nCenturyQ - nE + 15) Mod 30
nK = nH \ 28
nP = 29 \ (nH + 1)
nQ = (21 - nGolden) \ 11
nI = (nK * nP * nQ - 1) * nK + nH
nJ = ((Annee \ 4 + Annee) + nI + 2 + nCenturyQ - nCentury) Mod 7
nJ = 28 + nI - nJ
If nJ <= 31 Then
Paques = DateSerial(Annee, 3, nJ)
Else
Paques = DateSerial(Annee, 4, nJ - 31)
End If
'-----------------
T(2, 1) = "Pâques"
T(2, 2) = CDate(Paques)
T(3, 1) = "L.Pâques"
T(3, 2) = CDate(Paques) + 1
T(4, 1) = "Fête Travail"
T(4, 2) = CDate("1/5/" & Annee)
T(5, 1) = "Victoire 1945"
T(5, 2) = CDate("8/5/" & Annee)
T(6, 1) = "Ascension"
T(6, 2) = CDate(Paques) + 39
T(7, 1) = "L.Pentecôte"
T(7, 2) = CDate(Paques) + 50
T(8, 1) = "Fête Nationale"
T(8, 2) = CDate("14/7/" & Annee)
T(9, 1) = "Assomption"
T(9, 2) = CDate("15/08/" & Annee)
T(10, 1) = "Toussaint"
T(10, 2) = CDate("1/11/" & Annee)
T(11, 1) = "Armistice"
T(11, 2) = CDate("11/11/" & Annee)
T(12, 1) = "Noël"
T(12, 2) = CDate("25/12/" & Annee)
JoursFeries = T
End Function
