1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93
|
Option Explicit
Dim JFeries(11) As Long
Dim LastRow As Long
Sub Calendrier()
Dim Depart As Long, Fin As Long, i As Long, j As Long
Dim iR As Long
Feuil1.Columns(1).Clear
Application.ScreenUpdating = False
Depart = CDate("1/1/" & Feuil1.Range("Annee"))
Fin = CDate("31/12/" & Feuil1.Range("Annee"))
iR = 1
For i = Depart To Fin
Feuil1.Cells(iR, 1).Value = i
iR = iR + 1
Next i
JoursFeries Feuil1.Range("Annee")
LastRow = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
For i = LastRow To 1 Step -1
For j = 1 To 11
If Feuil1.Cells(i, 1) = JFeries(j) Or Weekday(Feuil1.Cells(i, 1)) = vbSaturday Or Weekday(Feuil1.Cells(i, 1)) = vbSunday Then
Feuil1.Range("A" & i).Delete Shift:=xlUp
Exit For
End If
Next j
Next i
LastRow = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
Feuil1.Range("A1:A" & LastRow).NumberFormatLocal = "jjj jj mmm aa"
Application.ScreenUpdating = True
End Sub
Private Function JoursFeries(An As Long)
Dim Nb As Long, Epacte As Long
Dim PLune As Date, LPaques As Date
Dim i As Long, j As Long, k As Long, tmp As Long
' Calcul du Lundi de Pâques
Nb = (An Mod 19) + 1
' Différence entre calendrier solaire et lunaire
Epacte = (11 * Nb - (3 + Int(2 + Int(An / 100)) * 3 / 7)) Mod 30
PLune = DateSerial(An, 4, 19) - ((Epacte + 6) Mod 30)
If Epacte = 24 Then PLune = PLune - 1
If Epacte = 25 And (An >= 1900 And An < 2200) Then PLune = PLune - 1
' Lundi de Pâques
LPaques = PLune - Weekday(PLune) + vbMonday + 7
Erase JFeries
' Jour de l'An
JFeries(1) = DateSerial(An, 1, 1)
' Paques
JFeries(2) = LPaques
' Ascension
JFeries(3) = LPaques + 38
' Pentecôte
JFeries(4) = LPaques + 49
' Fete du travail
JFeries(5) = DateSerial(An, 5, 1)
' Anniversire 1945
JFeries(6) = DateSerial(An, 5, 8)
' Fete Nationale
JFeries(7) = DateSerial(An, 7, 14)
' Assomption
JFeries(8) = DateSerial(An, 8, 15)
' Toussaint
JFeries(9) = DateSerial(An, 11, 1)
' Armistice 1918
JFeries(10) = DateSerial(An, 11, 11)
' Noel
JFeries(11) = DateSerial(An, 12, 25)
' Tri
For i = 1 To UBound(JFeries)
j = i
For k = j + 1 To UBound(JFeries)
If JFeries(k) <= JFeries(j) Then j = k
Next k
If i <> j Then
tmp = JFeries(j)
JFeries(j) = JFeries(i)
JFeries(i) = tmp
End If
Next i
End Function |
Partager