Pour ajouter des noms à cette liste (...) faire un "Inserrer" dans la liste, taper le nom, et éventuellement faire un tri de la liste pour que l'USF soit rempli dans l'ordre alphabétique...
je ne comprends pas comment on fait pour choisir la couleur de fond pour chaque agent
Sub WeekEnd()
Dim Cellule As Range, Premier As Boolean, I As Integer
Premier = True
Application.DisplayAlerts = False
For Each Cellule In Selection
If Premier = True Then
If Weekday(Cellule) = 1 Or Weekday(Cellule) = 7 Then
Range(Cells(Cellule.Row, 1), Cells(Cellule.Row + 1, 1)).Interior.ColorIndex = 15
For I = 2 To [COLOR=red][B]7 [COLOR=seagreen]' nombre de salles +1[/COLOR][/B][/COLOR]
Range(Cells(Cellule.Row, I), Cells(Cellule.Row + 1, I)).Interior.ColorIndex = 15
Range(Cells(Cellule.Row, I), Cells(Cellule.Row + 1, I)).Merge
Next I
End If
Premier = False
Else
Premier = True
End If
Next
Application.DisplayAlerts = True
End Sub
Sub Fériés()
Dim Cellule As Range, Premier As Boolean, I As Integer, Jours, Férié As Boolean
Premier = True
Application.DisplayAlerts = False
On Error Resume Next
For Each Cellule In Selection
If Premier = True Then
Jours = JoursFériés("2010")
Férié = False
For I = 0 To UBound(Jours)
If Cellule = Jours(I) Then Férié = True
Next I
If Férié = True Then
Range(Cells(Cellule.Row, 1), Cells(Cellule.Row + 1, 1)).Interior.ColorIndex = 3
For I = 2 To [B][COLOR=#ff0000]7 [/COLOR][COLOR=seagreen]' nombre de salles +1[/COLOR][/B]
Range(Cells(Cellule.Row, I), Cells(Cellule.Row + 1, I)).Interior.ColorIndex = 3
Range(Cells(Cellule.Row, I), Cells(Cellule.Row + 1, I)).Merge
Next I
End If
Premier = False
Else
Premier = True
End If
Next
On Error GoTo 0
Application.DisplayAlerts = True
End Sub
Le plus simple, c'est de modifier les macros de construction et de rebâtir une année à ces endroits précis
Tout est là, il te suffit d'appliquer les 4 macros après sélection sur un onglet vide (j'aurais pu le faire en une seule, mais à titre didactique, il est intérressant de voir ce que fait chaque macro, ce qui t'aurait permis de voir la modif à faire). Je n'ai jamais parlé d'insertion de colonne...Petite explication de texte sur les macros que j'y avais laissé. Pour préparer l'onglet 2011 (attention de bien l'appeler par l'année, sinon, les macros d'affichage ne fonctionneront pas), sélectionner de A3 à A731 (733 pour les années bissextiles).
Lancer dans le module Préparation la sub Remplissage, puis la sub Fusion, puis la sub WeekEnd et enfin la sub Fériés, il ne reste plus qu'à mettre le quadrillage, la hauteur des lignes à 10 et les entêtes (magique, non?)...
Quelle idée de travailler en Alsace/MoselleJe tente de modifier la macro "fonction" et d'insérer le calcul de 2 joures fériés supplémentaires: le vendredi saint qui précède le dimanche de Pâques et la saint-etienne (26 déc.)
Arr(11) = LPaques - 3 - Ajust
Arr(12) = DateSerial(An, 12, 26) - Ajust
Function JoursFériés(An)
' Détermination perpétuelle des jours fériés par année - Résultats sous forme de tableau
' Frédéric Sigoneau
Dim NbOr, Epacte, Ajust As Integer
Dim PLune, LPaques, Arr([COLOR=red][B]12[/B][/COLOR]) As Long
If ActiveWorkbook.Date1904 Then Ajust = 1462
'calcul du Lundi de Pâques
NbOr = (An Mod 19) + 1
Epacte = (11 * NbOr - (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
LPaques = PLune - Weekday(PLune) + vbMonday + 7 'Lundi Pâques
'tableau des fériés
Arr(0) = DateSerial(An, 1, 1) - Ajust
Arr(1) = LPaques - Ajust
Arr(2) = LPaques + 38 - Ajust 'Ascension
Arr(3) = LPaques + 49 - Ajust 'Pentecôte
Arr(4) = DateSerial(An, 5, 1) - Ajust
Arr(5) = DateSerial(An, 5, 8) - Ajust
Arr(6) = DateSerial(An, 7, 14) - Ajust
Arr(7) = DateSerial(An, 8, 15) - Ajust
Arr(8) = DateSerial(An, 11, 1) - Ajust
Arr(9) = DateSerial(An, 11, 11) - Ajust
Arr(10) = DateSerial(An, 12, 25) - Ajust
[COLOR=red][B] Arr(11) = LPaques - 3 - Ajust[/B][/COLOR]
[B][COLOR=red] Arr(12) = DateSerial(An, 12, 26) - Ajust[/COLOR][/B]
'tri du tableau
Dim I%, J%, K%, tmp
For I = LBound(Arr) To UBound(Arr)
J = I
For K = J + 1 To UBound(Arr)
If Arr(K) <= Arr(J) Then J = K
Next K
If I <> J Then
tmp = Arr(J): Arr(J) = Arr(I): Arr(I) = tmp
End If
Next I
'renvoi du résultat
On Error GoTo Fin
If Application.Caller.Rows.Count > 1 Then
JoursFériés = Application.Transpose(Arr)
Exit Function
End If
Fin:
JoursFériés = Arr
End Function 'fs