Attribute VB_Name = "ListeFeries"
'Permet d'écrire rapidement la liste des jours fériés d'une
'ou plusieurs années dans une feuille cachée du classeur actif
'et d'affecter un nom à cette liste.
'Ecrite pour les 11 jours fériés français, mais facilement adaptable.
'FS, juin 2001
Sub EcritFeries()
Dim DimanchePaques, Saisie, Nom, An
Dim sht As Worksheet, Valide As Boolean
Dim posTiret, posPVirg, tabAns(), tabDetails
Dim i, j, AnUn, AnFin, Période, tmpS
Dim Titre$, Msg$, ModeEmploi$
Set sht = ActiveWorkbook.ActiveSheet
Titre = "Jours fériés"
Msg = "Établir une liste de jours fériés pour une ou plusieurs années." _
& vbLf & vbLf
ModeEmploi = "Période autorisée : 1900-2099" & vbLf & _
"(les années doivent être saisies avec 4 chiffres)" & vbLf & _
"Séparateurs autorisés : ';' (point virgule), '-' (tiret)" & vbLf & _
"Vous pouvez saisir :" & vbLf & _
" - une ou des années isolées (2001;2002)" & vbLf & _
" - ou des séries d'années (2001-2003)" & vbLf & _
" - ou les deux (2001;2003-2007;2010)"
'saisie et contrôle de la saisie
Do
Valide = True
Saisie = InputBox(Msg & ModeEmploi, Titre)
'aucune date saisie ou clic sur Annuler
If Saisie = "" Then Exit Sub
'contrôle de la saisie
'exemple de saisie : 2001;2002;2010-2012
'A- Récupération des éléments de la saisie
' 1- année(s) isolée(s) ou séries : séparées par des points virgule
' ex : 2001;2002;2010-2012 --> 3 éléments
tmpS = Saisie & ";": i = 0: ReDim tabAns(i)
posPVirg = InStr(1, tmpS, ";")
Do
tabAns(i) = Left(tmpS, posPVirg - 1)
'1er contrôle :
'les éléments doivent avoir 4 (année isolée) ou 9 (série) caractères
If Not (Len(tabAns(i)) = 4 Or Len(tabAns(i)) = 9) Then
Valide = False
Exit Do
End If
tmpS = Right(tmpS, Len(tmpS) - posPVirg)
posPVirg = InStr(1, tmpS, ";")
If posPVirg <> 0 Then
i = i + 1
ReDim Preserve tabAns(i)
End If
Loop Until posPVirg = 0
' 2- séries d'années : séparées par des tirets
' ex : si 2010-2012 --> restituer 2010,2011,2012
' sinon, conserver les éléments isolés (2001,2002)
If Valide Then
j = 0: ReDim tabDetails(j)
For i = LBound(tabAns) To UBound(tabAns)
tmpS = tabAns(i)
posTiret = InStr(1, tmpS, "-")
If posTiret <> 0 Then
AnUn = Left(tmpS, posTiret - 1)
AnFin = Right(tmpS, Len(tmpS) - posTiret)
'2ème contrôle :
'la dernière année d'une série doit être plus grande
'que la première...
If AnFin < AnUn Then
Valide = False
Exit For
End If
tabDetails(j) = AnUn
Do While tabDetails(j) < AnFin
j = j + 1: ReDim Preserve tabDetails(j)
'3ème contrôle :
'les éléments d'une série doivent être des nombres
On Error Resume Next
tabDetails(j) = CStr(CLng(tabDetails(j - 1) + 1))
If Err <> 0 Then
On Error GoTo 0
Valide = False
Exit Do
Exit For
End If
Loop
Else
tabDetails(j) = tabAns(i)
End If
If i < UBound(tabAns) Then
j = j + 1: ReDim Preserve tabDetails(j)
End If
Next
End If
'4ème contrôle :
'contôle de la plage des dates saisies
If Valide Then
For i = LBound(tabDetails) To UBound(tabDetails)
An = tabDetails(i)
If An < 1900 Or An > 2099 Then Valide = False
Exit For
Next
End If
'si saisie non valide, RAZ des tableaux
If Not Valide Then
Erase tabAns: Erase tabDetails
End If
Loop Until Valide 'fin saisie et contrôle de la saisie
'nouvelle feuille pour écrire la liste
ActiveWorkbook.Sheets.Add
On Error Resume Next
ActiveSheet.Name = "Fériés " & Saisie
If Err <> 0 Then
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
MsgBox "La liste des fériés pour " & Saisie & _
" existe déjà dans ce classeur."
Exit Sub
End If
'écriture de la liste
For i = LBound(tabDetails) To UBound(tabDetails)
An = tabDetails(i)
'Cette formule interminable est de Jean-Paul Mesters (Windows News 06/2001)
'Elle donne la date du dimanche de Pâques jusqu'en 2099. Elle présente
'l'intérêt d'être insensible au calendrier du classeur (1900/1904)
DimanchePaques = "=DATE(" & An & ";SI((25-MOD((11*MOD(" & An & _
"-1900;19)+4-ENT((7*MOD(" & An & "-1900;19)+1)/19));29)-MOD(" & An & _
"-1900+ENT((" & An & "-1900)/4)+31-MOD((11*MOD(" & An & _
"-1900;19)+4-ENT((7*MOD(" & An & _
"-1900;19)+1)/19));29);7))>0;4;3);SI((25-MOD((11*MOD(" & An & _
"-1900;19)+4-ENT((7*MOD(" & An & _
"-1900;19)+1)/19));29)-MOD(" & An & "-1900+ENT((" & An & _
"-1900)/4)+31-MOD((11*MOD(" & An & "-1900;19)+4-ENT((7*MOD(" & An & _
"-1900;19)+1)/19));29);7))>0;(25-MOD((11*MOD(" & An & _
"-1900;19)+4-ENT((7*MOD(" & An & "-1900;19)+1)/19));29)-MOD(" & An & _
"-1900+ENT((" & An & "-1900)/4)+31-MOD((11*MOD(" & An & _
"-1900;19)+4-ENT((7*MOD(" & An & _
"-1900;19)+1)/19));29);7));31+(25-MOD((11*MOD(" & An & _
"-1900;19)+4-ENT((7*MOD(" & An & _
"-1900;19)+1)/19));29)-MOD(" & An & "-1900+ENT((" & An & _
"-1900)/4)+31-MOD((11*MOD(" & An & "-1900;19)+4-ENT((7*MOD(" & An & _
"-1900;19)+1)/19));29);7))))"
'Modifier le chiffre 11 pour adapter la macro
'au nombre de jours fériés souhaité
Range("A" & (i * 11) + 1).Select
'liste des fériés (modifiable)
ActiveCell(1).FormulaLocal = "=Date(" & An & ";1;1)" 'jour de l'an
ActiveCell(2).FormulaLocal = DimanchePaques & "+1" 'lundi Pâques
ActiveCell(3).FormulaLocal = DimanchePaques & "+39" 'jeudi Ascencion
ActiveCell(4).FormulaLocal = DimanchePaques & "+50" 'lundi Pentecôte
ActiveCell(5).FormulaLocal = "=Date(" & An & ";5;1)" 'fête du travail
ActiveCell(6).FormulaLocal = "=Date(" & An & ";5;8)" 'victoire 1945
ActiveCell(7).FormulaLocal = "=Date(" & An & ";7;14)" 'fête nationale
ActiveCell(8).FormulaLocal = "=Date(" & An & ";8;15)" 'assomption
ActiveCell(9).FormulaLocal = "=Date(" & An & ";11;1)" 'toussaint
ActiveCell(10).FormulaLocal = "=Date(" & An & ";11;11)" 'armistice 1918
ActiveCell(11).FormulaLocal = "=Date(" & An & ";12;25)" 'noël
Next i
'tri, définition d'un nom et format des dates
Range("A1").Select
'(modifier le chiffre 11 si nombre jours fériés modifié)
ActiveCell.Range("A1:A" & i * 11).Select
ActiveCell.Sort ActiveCell
'changer ou supprimer les caractères interdits dans les noms
Nom = Application.WorksheetFunction.Substitute(Saisie, ";", "_")
Nom = Application.WorksheetFunction.Substitute(Nom, "-", "")
Nom = "Feries" & Nom
ActiveWorkbook.Names.Add Nom, Selection
Selection.NumberFormatLocal = "jj/mm/aaaa"
'masquage de la feuille (la plage nommée reste accessible)
ActiveSheet.Visible = xlVeryHidden
sht.Select
End Sub
Je t ai simplement mailé un prog qui se trouve sur ce site : http://perso.wanadoo.fr/frederic.sigonneau/
il est tres bien ...
Par contre je n ai pas testé mais ca doit marcher ...
Laeti
