XL 2019 Remplacer des formules par une macro
- Initiateur de la discussion chich
- Date de début
Solution
Bonsoir à toutes et à tous,
bonsoir @chich
Surtout que j'ai souvent du retard à l’allumage ...
Bon je passe à autre chose, j'ai avancé sur la question de @chich , je dois encore régler le tour de rôle des astreintes, dont j'ai pas mal simplifié les formules, et les formats conditionnels.
Pour les changements de période et la saisie des absences c'est fait, le planning est mis à jour sans formule.
Du coup mon PC se traîne moins.
Au fait pour le tour de rôle, ne faut-il pas tenir compte des semaines de l'année précédant celles qui sont affichées ?
Voir PJ
Je continue ...
bonsoir @chich
Et d'autres préfèrent ne pas froisser ceux qui se sont investis
Surtout que j'ai souvent du retard à l’allumage ...
Bon je passe à autre chose, j'ai avancé sur la question de @chich , je dois encore régler le tour de rôle des astreintes, dont j'ai pas mal simplifié les formules, et les formats conditionnels.
Pour les changements de période et la saisie des absences c'est fait, le planning est mis à jour sans formule.
Du coup mon PC se traîne moins.
Au fait pour le tour de rôle, ne faut-il pas tenir compte des semaines de l'année précédant celles qui sont affichées ?
Voir PJ
Je continue ...
Dernière édition:
TooFatBoy
XLDnaute Barbatruc
Oui, tout à fait. C'est exactement ce que ma réponse sous-entendait. Nous sommes parfaitement d'accord.Et d'autres préfèrent ne pas froisser ceux qui se sont investis
ReBonsoir à toutes et à tous,
bonsoir @chich
Et d'autres préfèrent ne pas froisser ceux qui se sont investis
Surtout que j'ai souvent du retard à l’allumage ...
Bon je passe à autre chose, j'ai avancé sur la question de @chich , je dois encore régler le tour de rôle des astreinte, dont j'ai pas mal simplifié les formule, et les formats conditionnels.
Pour les changement de période et la saisie des absences c'est fait, le planning est mis à jour sans formule.
Du coup mon PC se traîne moins.
Au fait pour le tour de rôle, ne faut-il pas tenir compte des semaines de l'année précédant celles qui sont affichées ?
Voir PJ
Je continue ...
Good job
Merci
Oui il faut tenir compte de la dernière semaine de l'année précédente et que ca serai bien une annualisation
et de garder la possibilité de pouvoir ajouter des collaborateurs si l'équipe s'agrandi .
bonne continuation
Bonsoir à toutes & à tous,
bonsoir @chich
Bon c'est la saison des travaux d'extérieurs, ça me ralenti (moi qui ne suis déjà pas rapide
).
Je crois que j'ai abouti : une feuille sans aucune formule ni format conditionnel (un comble dans notre tableur préféré
!)
Cependant je n'ai pas pris en charge le RàZ de la zone de saisie lors ce changement d'année.
Elle redéfinit les noms "Planning_Collaborateurs" (zone d'affichage des absences par jour du planning et par collaborateur) et "ZoneSaisie" (zone de saisie des absences sur 12 périodes) et scrute ou remplit ces plages.
MAIS je n'ai pas pris en charge la modification de l'onglet Absence (ajout d'une ligne et de 14 lignes dans ces deux zones avec mise en forme etc. Ça pourrait faire l'objet d'un autre fil.
La macro se déclenche sur : un changement d'année ou de mois ; une modification dans la zone de saisie des dates d'absence.
Pour les formats (couleur de fond et de police) je me réfère à celles des tables "tb_Collaborateurs" et "tb_Type_Arrêt", tu peux les modifier si le cœur t'en dit. (cependant, tu devras adapter la mise en forme de l'onglet "absences" (liste des collaborateurs A10:A12 , et colonne A de la zone de saisie)
Voilà
Voir la pièce jointe
Ci-Après les noms utilisés et le code des 3 macros
Le tableaux structurés
Les noms définis
Code
Variables Public
Worksheet_Change
ChangePériode
LireAbsences
bonsoir @chich
Bon c'est la saison des travaux d'extérieurs, ça me ralenti (moi qui ne suis déjà pas rapide
).Je crois que j'ai abouti : une feuille sans aucune formule ni format conditionnel (un comble dans notre tableur préféré
!)C'est fait, lors d'une modification de l'année du planning, la macro demande le N° du collaborateur ayant assuré l'astreinte de la semaine 52 ou 53 de l'année précédente. C'est ce n° qui est stocké en A7 (nom "Der_An_Préc"). Les astreintes sont évaluées sur toute l'année choisie, le planning affiché est, en quelque sorte, une fenêtre de 6 semaines sur cette année.
Cependant je n'ai pas pris en charge le RàZ de la zone de saisie lors ce changement d'année.
C'est fait, ou presque : la macro tient compte du nombre de collaborateurs dans la table "tb_Collaborateurs".
Elle redéfinit les noms "Planning_Collaborateurs" (zone d'affichage des absences par jour du planning et par collaborateur) et "ZoneSaisie" (zone de saisie des absences sur 12 périodes) et scrute ou remplit ces plages.
MAIS je n'ai pas pris en charge la modification de l'onglet Absence (ajout d'une ligne et de 14 lignes dans ces deux zones avec mise en forme etc. Ça pourrait faire l'objet d'un autre fil.
La macro se déclenche sur : un changement d'année ou de mois ; une modification dans la zone de saisie des dates d'absence.
Pour les formats (couleur de fond et de police) je me réfère à celles des tables "tb_Collaborateurs" et "tb_Type_Arrêt", tu peux les modifier si le cœur t'en dit. (cependant, tu devras adapter la mise en forme de l'onglet "absences" (liste des collaborateurs A10:A12 , et colonne A de la zone de saisie)
Voilà
Voir la pièce jointe
Ci-Après les noms utilisés et le code des 3 macros
Le tableaux structurés
| tb_Année | liste des années ( 11 années, commence à année courante - 4 -modifiable) |
| tb_Mois | liste des noms de mois |
| tb_Collaborateurs | liste des collaborateurs, avec couleur de fond et de police. |
| tb_Type_Arrêt | liste des motif d'arrêt, avec couleur de fond et de police. |
| tb_Fériés | Jours fériés sur 3 ans (commence à année choisie -1) automatique. |
Les noms définis
| Année | =absence!$A$1 | Année choisie |
| Mois | =absence!$A$2 | Mois choisi |
| DateDéb | =absence!$A$4 | Date de début sur le planning |
| Der_An_Préc | =absence!$A$7 | N° du collaborateur qui a assuré la dernière astreinte de l'année précédente |
| Limite | =absence!$A$8 | Nombre d'absences déclenchant l'alerte |
| Fériés_An | =Année+CHOISIR(NB.SI(Tables!$I$2:$I15;"Jour de l'an");-1;0;1) | Année dans la table tb_Fériés, pour la calcul de pâques |
| Pâques | =SI(ET(Fériés_An>=1900;Fériés_An<=2204); DATE(Fériés_An;3;29,56+0,979*MOD(204-11*MOD(Fériés_An;19);30) -JOURSEM(DATE(Fériés_An;3;28,56+0,979*MOD(204-11*MOD(Fériés_An;19);30)))); "Hors domaine formule") | Pâques en fonction de la position dans la table tb_Fériés |
| Planning_Mois | =absence!$B$1:$AQ$1 | Ligne affichant le mois du planning |
| Planning_Semaines | =absence!$B$2:$AQ$2 | Ligne affichant le N° de semaine du planning |
| Planning_Curseur | =absence!$B$3:$AQ$3 | Ligne pour afficher le curseur sur la date d'aujourd'hui dans le planning |
| Planning_Dates | =absence!$B$4:$AQ$4 | Ligne contenant le quantième du planning |
| Planning_Jours | =absence!$B$5:$AQ$5 | Ligne contenant le jour de la semaine du planning |
| Planning_Astreintes | =absence!$B$6:$AQ$6 | Ligne contenant le nom du collaborateur d'astreinte |
| Planning_IdAstreintes | =absence!$B$7:$AQ$7 | Ligne contenant le N° du collaborateur d'astreinte |
| Planning_Alertes | =absence!$B$8:$AQ$8 | Ligne affichant l'alerte si le nombre d'absences atteint la limite |
| Planning_ComptageAbsences | =absence!$B$9:$AQ$9 | Ligne affichant le nombre d'absences pour chaque jour du planning |
| Planning_Collaborateurs | =absence!$B$10:$AQ$12 | Zone contenant les motifs d'absence pour chaque jour et chaque collaborateur |
| ZoneSaisie | =absence!$B$13:$AE$54 | Zone de saisie des absences |
Code
Variables Public
VB:
Const NbGpL As Byte = 2 'Nbr de grpe de lignes par collaborateur
Const NbGpC As Byte = 6 'Nbr de grpe de colonnes par lignes de saisie
Const NbSem As Byte = 6 'Nbr de semaine dans le planning
Dim Arrêts, Collab, ZoneSaisie 'Tableaux des motifs d'arrêt, des collaborateurs, de la Zone de Saisie des absences
Dim CoulArrêt, CoulCLB
Dim NbCLB%, NbMA% 'Nbr collaborateurs, Nbr Motifs d'arrêt
Dim DateDéb As Date, DateFin As Date 'Date de début et date de fin du planning affichéWorksheet_Change
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Application.ScreenUpdating = False
Collab = Tables.[tb_Collaborateurs].Value: NbCLB = UBound(Collab, 1)
Arrêts = Tables.[tb_Type_Arrêt].Value: NbMA = UBound(Arrêts, 1)
ReDim CoulCLB(1 To NbCLB, 1 To 2)
ReDim CoulArrêt(1 To NbMA, 1 To 2)
i = 0
For Each CLB In Tables.[tb_Collaborateurs]
i = i + 1
CoulCLB(i, 1) = CLB.Interior.Color
CoulCLB(i, 2) = CLB.Font.Color
Next
i = 0
For Each Arrêt In Tables.[tb_Type_Arrêt]
i = i + 1
CoulArrêt(i, 1) = Arrêt.Interior.Color
CoulArrêt(i, 2) = Arrêt.Font.Color
Next
'Redéfinir les nom dépendant du Nbr Arrêts et du Nbr Collaborateurs
With ThisWorkbook
.Names("Planning_Collaborateurs").RefersTo = "=" & Me.[Planning_ComptageAbsences].Offset(1).Resize(NbCLB).Address
.Names("ZoneSaisie").RefersTo = "=" & Me.[Planning_Collaborateurs].Offset(NbCLB).Resize((NbMA + 1) * NbGpL * NbCLB, NbGpC * 5).Address
End With
'Aiguillage en fonction de la cellule modifiée
Select Case True
Case Target.Address = Me.[Année].Address Or Target.Address = Me.[Mois].Address
If Target.Address = Me.[Année].Address Then
Rép = Application.InputBox(Prompt:="N° du collaborateur ayant assuré l'astreinte de la dernière semaine de " & Me.[Année] - 1, _
Title:="Changement d'année", Type:=1)
If Not TypeName(Rép) = "Booleen" Then Me.[Der_An_Préc] = Rép
End If
ChangePériode
LireAbsences
Case Not Intersect(Target, Me.[ZoneSaisie]) Is Nothing
LireAbsences
End Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End SubChangePériode
VB:
Sub ChangePériode()
Dim tbD(0 To 1, 0 To NbSem * 7 - 1), tbM(0 To NbSem * 7 - 1)
Dim Mois$, m As Byte, Année%, d
Mois = Me.[Mois]
Année = Me.[Année]
d = CLng(DateValue("1 " & Mois & " " & Année)) '1er du mois en cours
DateDébut = CDate(Evaluate(d & "+CHOOSE(WEEKDAY(" & d & ",2),0,-1,-2,-3,3,2,1)")) 'Début de la semaine contenant le début du mois en cours
Me.[DateDéb] = DateDébut 'Début du planning affiché
DateFin = DateDébut + (NbSem + 7) - 1 'Fin du planning Affiché
'Positionnement du curseur sur la date actuelle (si affichée)
Me.[Planning_Curseur].Clear
If Date >= DateDébut And Date <= DateFin Then
With Me.[Planning_Curseur].Cells(Date - DateDébut + 1)
.Font.Name = "Wingdings"
.Font.Size = 14
.Font.Color = 16777215
.Interior.Color = 32768
.Value = "ê"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
'Remise en forme du calendrier sur NbSem semaines
'Raz de la ligne Mois
m = 0
Me.[Planning_Mois].ClearContents
Me.[Planning_Mois].Borders.LineStyle = xlNone
Me.[Planning_Mois].Borders(xlEdgeBottom).LineStyle = xlContinuous
'MàJ des quantièmes et des jours de la semaine
With Me.[Planning_dates:Planning_jours]
.Interior.Color = 16777215
.Font.Color = 0
'Boucle sur les NbSem*7 jours
For i = 0 To NbSem * 7 - 1
d = DateDébut + i
'Réhaussement des jours fériés
If Evaluate("OR(" & CLng(d) & "=Tb_Fériés[Date])") = True Then
With .Cells(i + 1).Resize(2, 1)
.Interior.Color = 5066944
.Font.Color = 16777215
End With
End If
'Mémoriser le quantième et le jour de la semaine
tbD(0, i) = Day(d)
tbD(1, i) = UCase(Left(Format(d, "ddd"), 1))
'Noter les changements de mois
If Month(d) <> m Then
m = Month(d)
Me.[Planning_Mois].Cells(i + 1) = Format(d, "mmm-yy")
Me.[Planning_Mois].Cells(i + 1).Borders(xlEdgeLeft).LineStyle = xlDouble
End If
Next i
'Ecrire les quantièmes et les jours de la semaine mémorisés
.Value = tbD
End With
'N° de semaine ISO pour les 6 semaines
For i = 0 To 35 Step 7
Me.[Planning_Semaines].Cells(1, i + 1) = "S " & Evaluate("ISOWEEKNUM(" & CLng(DateDébut) + i & ")")
Next
End SubLireAbsences
VB:
Sub LireAbsences()
Dim I0, IX, Dmin, Dmax, CLB As Byte, Lgn%
Mois = Me.[Mois]
Année = Me.[Année]
DateDéb = Me.[DateDéb].Value
DateFin = DateDéb + (NbSem * 7) - 1
ZoneSaisie = Me.[ZoneSaisie].Value
Dmin = 3000000: Dmax = 0
NbLgn = NbGpL * (NbMA) * NbGpC
'Lecture du tableau de saisie et calcul des durées des absences
ReDim tbDéb(NbLgn, NbCLB), tbFin(NbLgn, NbCLB)
For CLB = 1 To NbCLB
For Lgn = 1 To NbLgn
LAbs = (((CLB - 1) Mod NbCLB) * (NbMA + 1) * NbGpL) + (Int((Lgn - 1) / (NbMA * NbGpC)) + 1) + Int((Lgn - 1) / 6) + 1
CAbsN = ((Lgn - 1) Mod NbGpC) * 5 + 3
tbDéb(Lgn, CLB) = ZoneSaisie(LAbs, ((Lgn - 1) Mod NbGpC) * 5 + 1)
tbFin(Lgn, CLB) = ZoneSaisie(LAbs, ((Lgn - 1) Mod NbGpC) * 5 + 4)
If IsDate(tbDéb(Lgn, CLB)) And tbDéb(Lgn, CLB) < Dmin Then Dmin = tbDéb(Lgn, CLB)
If IsDate(tbFin(Lgn, CLB)) And tbFin(Lgn, CLB) > Dmax Then Dmax = tbFin(Lgn, CLB)
If IsDate(tbDéb(Lgn, CLB)) And IsDate(tbFin(Lgn, CLB)) Then
ZoneSaisie(LAbs, CAbsN) = CLng(tbFin(Lgn, CLB)) - CLng(tbDéb(Lgn, CLB)) + 1
End If
Next Lgn
Next CLB
Me.[ZoneSaisie].Value = ZoneSaisie
'Limites de la période globale (couvrant toutes les absences posées et l'année affichée)
'1er jour de la semaine du début de la période globale
I0 = CLng(DateSerial(Year(IIf(DateSerial(Année, 1, 1) < Dmin, DateValue("1 " & Mois & " " & Année), Dmin)), 1, 1))
I0 = CDate(Evaluate(I0 & "+CHOOSE(WEEKDAY(" & I0 & ",2),0,-1,-2,-3,3,2,1)"))
'Dernier jour de la semaine de la fin de la période globale
IX = CLng(DateSerial(Année, 12, 1))
IX = CDate(Evaluate(IX & "+CHOOSE(WEEKDAY(" & I0 & ",2),0,-1,-2,-3,3,2,1)")) + NbSem * 7 - 1
IX = DateSerial(Year(IIf(IX > Dmax, IX, Dmax)), 12, 31)
IX = IX - Weekday(IX, vbMonday) + IIf(WorksheetFunction.IsoWeekNum(IX) = 1, 0, 7)
'Remplissage du tableau global (sur toutes la période définie par les dates connues)
ReDim tb_An(1 To NbCLB, 1 To CLng(IX - I0) + 1, 1 To 2) 'Tableau(nb collaborateur, nb jours de la période globale) pour recueillir les types d'arrêts
ReDim tb_nbAbs(1 To 1, 1 To CLng(IX - I0) + 1) 'Tableau de comptage d'absences par jour sur la période globale
For i = 1 To UBound(tb_nbAbs, 2): tb_nbAbs(1, i) = 0: Next i 'Initialisation à 0
For CLB = 1 To NbCLB 'Boucle sur le nbr de collaborateurs
For Lgn = 1 To NbLgn 'Boucle sur le nombre de lignes par collaborateur
If Not (IsEmpty(tbDéb(Lgn, CLB)) Or IsEmpty(tbFin(Lgn, CLB))) Then
Idx = (Lgn - 1) Mod NbMA + 1
Arrêt = Arrêts(Idx, 1) 'Type d'arrêt en fonction du N° de la ligne courante
For d = CLng(tbDéb(Lgn, CLB) - I0 + 1) To CLng(tbFin(Lgn, CLB) - I0 + 1) 'Boucle sur les dates de la période d'absence
tb_An(CLB, d, 1) = Arrêt 'Type d'arrêt
tb_An(CLB, d, 2) = Idx 'Type d'arrêt
tb_nbAbs(1, d) = tb_nbAbs(1, d) + 1 'Cumul du nombre d'absences pour la date d
Next
End If
Next
Next
'Remplissage du tableau des types d'absence pour les dates affichées du planning
ReDim Tb_Abs(1 To NbCLB, 1 To CLng(DateFin - DateDéb + 1))
ReDim Tb_cumul(1 To 1, 1 To CLng(DateFin - DateDéb + 1))
Limite = Me.[Limite].Value
Col = 0
For d = CLng(DateDéb - I0 + 1) To CLng(DateFin - I0 + 1)
Col = Col + 1
For CLB = 1 To NbCLB
Tb_Abs(CLB, Col) = tb_An(CLB, d, 1)
If Tb_Abs(CLB, Col) <> "" Then
Me.[Planning_Collaborateurs].Cells(CLB, Col).Interior.Color = CoulArrêt(tb_An(CLB, d, 2), 1)
Me.[Planning_Collaborateurs].Cells(CLB, Col).Font.Color = CoulArrêt(tb_An(CLB, d, 2), 2)
Else
Me.[Planning_Collaborateurs].Cells(CLB, Col).Interior.Color = 16777215
Me.[Planning_Collaborateurs].Cells(CLB, Col).Font.Color = 0
End If
Next
Tb_cumul(1, Col) = tb_nbAbs(1, d)
Me.[Planning_Alertes].Cells(Col).Font.Color = IIf(Tb_cumul(1, Col) >= Limite, 255, 32768)
Next
Me.[Planning_Collaborateurs].Value = Tb_Abs
Me.[Planning_ComptageAbsences].Value = Tb_cumul
'Dates de l'année suivie
'Premier jour de la semaine 1
JDéb = CLng(DateSerial(Année, 1, 1))
JDéb = CDate(Evaluate(JDéb & "+CHOOSE(WEEKDAY(" & JDéb & ",2),0,-1,-2,-3,3,2,1)"))
'Dernier jour du planning pour le mois de décembre
JFin = CLng(DateSerial(Année, 12, 1))
JFin = CDate(Evaluate(JFin & "+CHOOSE(WEEKDAY(" & JFin & ",2),0,-1,-2,-3,3,2,1)")) + NbSem * 7 - 1
ReDim tbAstr(1 To JFin - JDéb + 1)
Dd = JDéb - I0
N° = Me.[Der_An_Préc].Value
For DLun = 0 To JFin - JDéb - 6 Step 7
Trouvé = 0
For n = 0 To NbCLB - 1
AbsSem = ""
CLB = (N° + n) Mod NbCLB + 1
For j = 1 To 7
Idx = Dd + DLun + j
AbsSem = AbsSem & tb_An(CLB, Idx, 1)
Next j
If AbsSem = "" Then
Trouvé = CLB
Exit For
End If
Next n
N° = Trouvé
For j = 1 To 7
tbAstr(DLun + j) = N°
Next j
Next DLun
ReDim tb1(1 To 1, 1 To NbSem * 7)
ReDim tb2(1 To 1, 1 To NbSem * 7)
Déb = CLng(DateDéb - JDéb)
With Me.[Planning_Astreintes]
For j = 1 To 42
tb1(1, j) = tbAstr(Déb + j)
If tb1(1, j) <> 0 Then
tb2(1, j) = WorksheetFunction.Index(Collab, tb1(1, j), 1)
.Cells(j).Interior.Color = CoulCLB(tb1(1, j), 1)
.Cells(j).Font.Color = CoulCLB(tb1(1, j), 2)
Else
.Cells(j).Interior.Color = 16777215
.Cells(j).Font.Color = 0
End If
Next
.Value = tb2
End With
Me.[Planning_IdAstreintes].Value = tb1
End SubBonjourBonsoir à toutes & à tous,
bonsoir @chich
Bon c'est la saison des travaux d'extérieurs, ça me ralenti (moi qui ne suis déjà pas rapide
Je crois que j'ai abouti : une feuille sans aucune formule ni format conditionnel (un comble dans notre tableur préféré
C'est fait, lors d'une modification de l'année du planning, la macro demande le N° du collaborateur ayant assuré l'astreinte de la semaine 52 ou 53 de l'année précédente. C'est ce n° qui est stocké en A7 (nom "Der_An_Préc"). Les astreintes sont évaluées sur toute l'année choisie, le planning affiché est, en quelque sorte, une fenêtre de 6 semaines sur cette année.
Cependant je n'ai pas pris en charge le RàZ de la zone de saisie lors ce changement d'année.
C'est fait, ou presque : la macro tient compte du nombre de collaborateurs dans la table "tb_Collaborateurs".
Elle redéfinit les noms "Planning_Collaborateurs" (zone d'affichage des absences par jour du planning et par collaborateur) et "ZoneSaisie" (zone de saisie des absences sur 12 périodes) et scrute ou remplit ces plages.
MAIS je n'ai pas pris en charge la modification de l'onglet Absence (ajout d'une ligne et de 14 lignes dans ces deux zones avec mise en forme etc. Ça pourrait faire l'objet d'un autre fil.
La macro se déclenche sur : un changement d'année ou de mois ; une modification dans la zone de saisie des dates d'absence.
Pour les formats (couleur de fond et de police) je me réfère à celles des tables "tb_Collaborateurs" et "tb_Type_Arrêt", tu peux les modifier si le cœur t'en dit. (cependant, tu devras adapter la mise en forme de l'onglet "absences" (liste des collaborateurs A10:A12 , et colonne A de la zone de saisie)
Voilà
Voir la pièce jointe
Ci-Après les noms utilisés et le code des 3 macros
Le tableaux structurés
tb_Année liste des années ( 11 années, commence à année courante - 4 -modifiable) tb_Mois liste des noms de mois tb_Collaborateurs liste des collaborateurs, avec couleur de fond et de police. tb_Type_Arrêt liste des motif d'arrêt, avec couleur de fond et de police. tb_Fériés Jours fériés sur 3 ans (commence à année choisie -1) automatique.
Les noms définis
Année =absence!$A$1 Année choisie Mois =absence!$A$2 Mois choisi DateDéb =absence!$A$4 Date de début sur le planning Der_An_Préc =absence!$A$7 N° du collaborateur qui a assuré la dernière astreinte de l'année précédente Limite =absence!$A$8 Nombre d'absences déclenchant l'alerte Fériés_An =Année+CHOISIR(NB.SI(Tables!$I$2:$I15;"Jour de l'an");-1;0;1) Année dans la table tb_Fériés, pour la calcul de pâques Pâques =SI(ET(Fériés_An>=1900;Fériés_An<=2204);
DATE(Fériés_An;3;29,56+0,979*MOD(204-11*MOD(Fériés_An;19);30)
-JOURSEM(DATE(Fériés_An;3;28,56+0,979*MOD(204-11*MOD(Fériés_An;19);30))));
"Hors domaine formule")Pâques en fonction de la position dans la table tb_Fériés Planning_Mois =absence!$B$1:$AQ$1 Ligne affichant le mois du planning Planning_Semaines =absence!$B$2:$AQ$2 Ligne affichant le N° de semaine du planning Planning_Curseur =absence!$B$3:$AQ$3 Ligne pour afficher le curseur sur la date d'aujourd'hui dans le planning Planning_Dates =absence!$B$4:$AQ$4 Ligne contenant le quantième du planning Planning_Jours =absence!$B$5:$AQ$5 Ligne contenant le jour de la semaine du planning Planning_Astreintes =absence!$B$6:$AQ$6 Ligne contenant le nom du collaborateur d'astreinte Planning_IdAstreintes =absence!$B$7:$AQ$7 Ligne contenant le N° du collaborateur d'astreinte Planning_Alertes =absence!$B$8:$AQ$8 Ligne affichant l'alerte si le nombre d'absences atteint la limite Planning_ComptageAbsences =absence!$B$9:$AQ$9 Ligne affichant le nombre d'absences pour chaque jour du planning Planning_Collaborateurs =absence!$B$10:$AQ$12 Zone contenant les motifs d'absence pour chaque jour et chaque collaborateur ZoneSaisie =absence!$B$13:$AE$54 Zone de saisie des absences
Code
Variables Public
VB:Const NbGpL As Byte = 2 'Nbr de grpe de lignes par collaborateur Const NbGpC As Byte = 6 'Nbr de grpe de colonnes par lignes de saisie Const NbSem As Byte = 6 'Nbr de semaine dans le planning Dim Arrêts, Collab, ZoneSaisie 'Tableaux des motifs d'arrêt, des collaborateurs, de la Zone de Saisie des absences Dim CoulArrêt, CoulCLB Dim NbCLB%, NbMA% 'Nbr collaborateurs, Nbr Motifs d'arrêt Dim DateDéb As Date, DateFin As Date 'Date de début et date de fin du planning affiché
Worksheet_Change
VB:Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Application.ScreenUpdating = False Collab = Tables.[tb_Collaborateurs].Value: NbCLB = UBound(Collab, 1) Arrêts = Tables.[tb_Type_Arrêt].Value: NbMA = UBound(Arrêts, 1) ReDim CoulCLB(1 To NbCLB, 1 To 2) ReDim CoulArrêt(1 To NbMA, 1 To 2) i = 0 For Each CLB In Tables.[tb_Collaborateurs] i = i + 1 CoulCLB(i, 1) = CLB.Interior.Color CoulCLB(i, 2) = CLB.Font.Color Next i = 0 For Each Arrêt In Tables.[tb_Type_Arrêt] i = i + 1 CoulArrêt(i, 1) = Arrêt.Interior.Color CoulArrêt(i, 2) = Arrêt.Font.Color Next 'Redéfinir les nom dépendant du Nbr Arrêts et du Nbr Collaborateurs With ThisWorkbook .Names("Planning_Collaborateurs").RefersTo = "=" & Me.[Planning_ComptageAbsences].Offset(1).Resize(NbCLB).Address .Names("ZoneSaisie").RefersTo = "=" & Me.[Planning_Collaborateurs].Offset(NbCLB).Resize((NbMA + 1) * NbGpL * NbCLB, NbGpC * 5).Address End With 'Aiguillage en fonction de la cellule modifiée Select Case True Case Target.Address = Me.[Année].Address Or Target.Address = Me.[Mois].Address If Target.Address = Me.[Année].Address Then Rép = Application.InputBox(Prompt:="N° du collaborateur ayant assuré l'astreinte de la dernière semaine de " & Me.[Année] - 1, _ Title:="Changement d'année", Type:=1) If Not TypeName(Rép) = "Booleen" Then Me.[Der_An_Préc] = Rép End If ChangePériode LireAbsences Case Not Intersect(Target, Me.[ZoneSaisie]) Is Nothing LireAbsences End Select Application.ScreenUpdating = True Application.EnableEvents = True End Sub
ChangePériode
VB:Sub ChangePériode() Dim tbD(0 To 1, 0 To NbSem * 7 - 1), tbM(0 To NbSem * 7 - 1) Dim Mois$, m As Byte, Année%, d Mois = Me.[Mois] Année = Me.[Année] d = CLng(DateValue("1 " & Mois & " " & Année)) '1er du mois en cours DateDébut = CDate(Evaluate(d & "+CHOOSE(WEEKDAY(" & d & ",2),0,-1,-2,-3,3,2,1)")) 'Début de la semaine contenant le début du mois en cours Me.[DateDéb] = DateDébut 'Début du planning affiché DateFin = DateDébut + (NbSem + 7) - 1 'Fin du planning Affiché 'Positionnement du curseur sur la date actuelle (si affichée) Me.[Planning_Curseur].Clear If Date >= DateDébut And Date <= DateFin Then With Me.[Planning_Curseur].Cells(Date - DateDébut + 1) .Font.Name = "Wingdings" .Font.Size = 14 .Font.Color = 16777215 .Interior.Color = 32768 .Value = "ê" .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End If 'Remise en forme du calendrier sur NbSem semaines 'Raz de la ligne Mois m = 0 Me.[Planning_Mois].ClearContents Me.[Planning_Mois].Borders.LineStyle = xlNone Me.[Planning_Mois].Borders(xlEdgeBottom).LineStyle = xlContinuous 'MàJ des quantièmes et des jours de la semaine With Me.[Planning_dates:Planning_jours] .Interior.Color = 16777215 .Font.Color = 0 'Boucle sur les NbSem*7 jours For i = 0 To NbSem * 7 - 1 d = DateDébut + i 'Réhaussement des jours fériés If Evaluate("OR(" & CLng(d) & "=Tb_Fériés[Date])") = True Then With .Cells(i + 1).Resize(2, 1) .Interior.Color = 5066944 .Font.Color = 16777215 End With End If 'Mémoriser le quantième et le jour de la semaine tbD(0, i) = Day(d) tbD(1, i) = UCase(Left(Format(d, "ddd"), 1)) 'Noter les changements de mois If Month(d) <> m Then m = Month(d) Me.[Planning_Mois].Cells(i + 1) = Format(d, "mmm-yy") Me.[Planning_Mois].Cells(i + 1).Borders(xlEdgeLeft).LineStyle = xlDouble End If Next i 'Ecrire les quantièmes et les jours de la semaine mémorisés .Value = tbD End With 'N° de semaine ISO pour les 6 semaines For i = 0 To 35 Step 7 Me.[Planning_Semaines].Cells(1, i + 1) = "S " & Evaluate("ISOWEEKNUM(" & CLng(DateDébut) + i & ")") Next End Sub
LireAbsences
VB:Sub LireAbsences() Dim I0, IX, Dmin, Dmax, CLB As Byte, Lgn% Mois = Me.[Mois] Année = Me.[Année] DateDéb = Me.[DateDéb].Value DateFin = DateDéb + (NbSem * 7) - 1 ZoneSaisie = Me.[ZoneSaisie].Value Dmin = 3000000: Dmax = 0 NbLgn = NbGpL * (NbMA) * NbGpC 'Lecture du tableau de saisie et calcul des durées des absences ReDim tbDéb(NbLgn, NbCLB), tbFin(NbLgn, NbCLB) For CLB = 1 To NbCLB For Lgn = 1 To NbLgn LAbs = (((CLB - 1) Mod NbCLB) * (NbMA + 1) * NbGpL) + (Int((Lgn - 1) / (NbMA * NbGpC)) + 1) + Int((Lgn - 1) / 6) + 1 CAbsN = ((Lgn - 1) Mod NbGpC) * 5 + 3 tbDéb(Lgn, CLB) = ZoneSaisie(LAbs, ((Lgn - 1) Mod NbGpC) * 5 + 1) tbFin(Lgn, CLB) = ZoneSaisie(LAbs, ((Lgn - 1) Mod NbGpC) * 5 + 4) If IsDate(tbDéb(Lgn, CLB)) And tbDéb(Lgn, CLB) < Dmin Then Dmin = tbDéb(Lgn, CLB) If IsDate(tbFin(Lgn, CLB)) And tbFin(Lgn, CLB) > Dmax Then Dmax = tbFin(Lgn, CLB) If IsDate(tbDéb(Lgn, CLB)) And IsDate(tbFin(Lgn, CLB)) Then ZoneSaisie(LAbs, CAbsN) = CLng(tbFin(Lgn, CLB)) - CLng(tbDéb(Lgn, CLB)) + 1 End If Next Lgn Next CLB Me.[ZoneSaisie].Value = ZoneSaisie 'Limites de la période globale (couvrant toutes les absences posées et l'année affichée) '1er jour de la semaine du début de la période globale I0 = CLng(DateSerial(Year(IIf(DateSerial(Année, 1, 1) < Dmin, DateValue("1 " & Mois & " " & Année), Dmin)), 1, 1)) I0 = CDate(Evaluate(I0 & "+CHOOSE(WEEKDAY(" & I0 & ",2),0,-1,-2,-3,3,2,1)")) 'Dernier jour de la semaine de la fin de la période globale IX = CLng(DateSerial(Année, 12, 1)) IX = CDate(Evaluate(IX & "+CHOOSE(WEEKDAY(" & I0 & ",2),0,-1,-2,-3,3,2,1)")) + NbSem * 7 - 1 IX = DateSerial(Year(IIf(IX > Dmax, IX, Dmax)), 12, 31) IX = IX - Weekday(IX, vbMonday) + IIf(WorksheetFunction.IsoWeekNum(IX) = 1, 0, 7) 'Remplissage du tableau global (sur toutes la période définie par les dates connues) ReDim tb_An(1 To NbCLB, 1 To CLng(IX - I0) + 1, 1 To 2) 'Tableau(nb collaborateur, nb jours de la période globale) pour recueillir les types d'arrêts ReDim tb_nbAbs(1 To 1, 1 To CLng(IX - I0) + 1) 'Tableau de comptage d'absences par jour sur la période globale For i = 1 To UBound(tb_nbAbs, 2): tb_nbAbs(1, i) = 0: Next i 'Initialisation à 0 For CLB = 1 To NbCLB 'Boucle sur le nbr de collaborateurs For Lgn = 1 To NbLgn 'Boucle sur le nombre de lignes par collaborateur If Not (IsEmpty(tbDéb(Lgn, CLB)) Or IsEmpty(tbFin(Lgn, CLB))) Then Idx = (Lgn - 1) Mod NbMA + 1 Arrêt = Arrêts(Idx, 1) 'Type d'arrêt en fonction du N° de la ligne courante For d = CLng(tbDéb(Lgn, CLB) - I0 + 1) To CLng(tbFin(Lgn, CLB) - I0 + 1) 'Boucle sur les dates de la période d'absence tb_An(CLB, d, 1) = Arrêt 'Type d'arrêt tb_An(CLB, d, 2) = Idx 'Type d'arrêt tb_nbAbs(1, d) = tb_nbAbs(1, d) + 1 'Cumul du nombre d'absences pour la date d Next End If Next Next 'Remplissage du tableau des types d'absence pour les dates affichées du planning ReDim Tb_Abs(1 To NbCLB, 1 To CLng(DateFin - DateDéb + 1)) ReDim Tb_cumul(1 To 1, 1 To CLng(DateFin - DateDéb + 1)) Limite = Me.[Limite].Value Col = 0 For d = CLng(DateDéb - I0 + 1) To CLng(DateFin - I0 + 1) Col = Col + 1 For CLB = 1 To NbCLB Tb_Abs(CLB, Col) = tb_An(CLB, d, 1) If Tb_Abs(CLB, Col) <> "" Then Me.[Planning_Collaborateurs].Cells(CLB, Col).Interior.Color = CoulArrêt(tb_An(CLB, d, 2), 1) Me.[Planning_Collaborateurs].Cells(CLB, Col).Font.Color = CoulArrêt(tb_An(CLB, d, 2), 2) Else Me.[Planning_Collaborateurs].Cells(CLB, Col).Interior.Color = 16777215 Me.[Planning_Collaborateurs].Cells(CLB, Col).Font.Color = 0 End If Next Tb_cumul(1, Col) = tb_nbAbs(1, d) Me.[Planning_Alertes].Cells(Col).Font.Color = IIf(Tb_cumul(1, Col) >= Limite, 255, 32768) Next Me.[Planning_Collaborateurs].Value = Tb_Abs Me.[Planning_ComptageAbsences].Value = Tb_cumul 'Dates de l'année suivie 'Premier jour de la semaine 1 JDéb = CLng(DateSerial(Année, 1, 1)) JDéb = CDate(Evaluate(JDéb & "+CHOOSE(WEEKDAY(" & JDéb & ",2),0,-1,-2,-3,3,2,1)")) 'Dernier jour du planning pour le mois de décembre JFin = CLng(DateSerial(Année, 12, 1)) JFin = CDate(Evaluate(JFin & "+CHOOSE(WEEKDAY(" & JFin & ",2),0,-1,-2,-3,3,2,1)")) + NbSem * 7 - 1 ReDim tbAstr(1 To JFin - JDéb + 1) Dd = JDéb - I0 N° = Me.[Der_An_Préc].Value For DLun = 0 To JFin - JDéb - 6 Step 7 Trouvé = 0 For n = 0 To NbCLB - 1 AbsSem = "" CLB = (N° + n) Mod NbCLB + 1 For j = 1 To 7 Idx = Dd + DLun + j AbsSem = AbsSem & tb_An(CLB, Idx, 1) Next j If AbsSem = "" Then Trouvé = CLB Exit For End If Next n N° = Trouvé For j = 1 To 7 tbAstr(DLun + j) = N° Next j Next DLun ReDim tb1(1 To 1, 1 To NbSem * 7) ReDim tb2(1 To 1, 1 To NbSem * 7) Déb = CLng(DateDéb - JDéb) With Me.[Planning_Astreintes] For j = 1 To 42 tb1(1, j) = tbAstr(Déb + j) If tb1(1, j) <> 0 Then tb2(1, j) = WorksheetFunction.Index(Collab, tb1(1, j), 1) .Cells(j).Interior.Color = CoulCLB(tb1(1, j), 1) .Cells(j).Font.Color = CoulCLB(tb1(1, j), 2) Else .Cells(j).Interior.Color = 16777215 .Cells(j).Font.Color = 0 End If Next .Value = tb2 End With Me.[Planning_IdAstreintes].Value = tb1 End Sub
super job merci beaucoup
j'ai plus qu'une question pour la formule qui génère le toure de permanence
Ou je peux définir par exemple les 3 premier qui peuvent prendre le toure de permanence
dans la liste des collaborateurs
dans le fichier démo anonymisé que j'ai joint
ce nombre et en A6
Bonne ajournée
Bonsoir à toutes & à tous,
bonsoir @chich
Ce n'était pas prévu, le plus simple, c'est sans doute de créer une liste des collaborateurs qui prennent part au tour d'astreinte.
Par contre
A bientôt
bonsoir @chich
Veux-tu dire que tu as une liste de collaborateurs et que seuls certains d'entre-eux assurent les astreintes ?
Ce n'était pas prévu, le plus simple, c'est sans doute de créer une liste des collaborateurs qui prennent part au tour d'astreinte.
Par contre
Je n'ai pas ce fichier joint ???
A bientôt
Dernière édition:
C'est dans le fichier que j'ai joint a ma demande
la formule me permet de définir le nombre en partant du premier collaborateur
la liste et de A9 A11
Re
donc si n est en A6, seuls les n premiers collaborateurs prennent part au tour de rôle.
Dans ton exemple ils prenaient tous part à ce tour de rôles (A6 = 3 et nbr collab =3) je n'avais pas vu de quoi il s'agissait (vu la complexité des formules)
Je regarde donc pour corriger cela.
A bientôt
donc si n est en A6, seuls les n premiers collaborateurs prennent part au tour de rôle.
Dans ton exemple ils prenaient tous part à ce tour de rôles (A6 = 3 et nbr collab =3) je n'avais pas vu de quoi il s'agissait (vu la complexité des formules)
Je regarde donc pour corriger cela.
A bientôt
Dernière édition:
Re
Bon j'ai une solution, mais je me pose une question :
Bon j'ai une solution, mais je me pose une question :
Le seuil d'alerte affiché (actuellement 2 (en A7 de ton fichier exemple)) est-ce pour l'ensemble des collaborateurs ou pour les n premiers assurant l'astreinte ?
Je penche pour le deuxième cas, mais je préfère que tu me confirmes.
Dernière édition:
Re
Bon je t'envoie ma solution sans retoucher à la façon dont le seuil d'alerte est interprété (sur tous les collaborateurs).
Pour la démo je suis passé à 5 collaborateurs.
A bientôt
Edit: Pièce jointe remplacée (erreur de fichier)
Bon je t'envoie ma solution sans retoucher à la façon dont le seuil d'alerte est interprété (sur tous les collaborateurs).
Pour la démo je suis passé à 5 collaborateurs.
A bientôt
Edit: Pièce jointe remplacée (erreur de fichier)
Dernière édition:
Re
2 c'est pour le nombre max de tous les collaborateurs en absence
Re, donc la version de mon post#25 doit convenir.
Ah oui il y a un plus caché : lorsque tu cliques sur un collaborateur en colonne A, cela fait défiler l'écran jusqu'à la zone de saisie de ce collaborateur !
Ah oui il y a un plus caché : lorsque tu cliques sur un collaborateur en colonne A, cela fait défiler l'écran jusqu'à la zone de saisie de ce collaborateur !
Bonsoir à toutes & à tous,
bonsoir @chich
Bon c'est la saison des travaux d'extérieurs, ça me ralenti (moi qui ne suis déjà pas rapide
Je crois que j'ai abouti : une feuille sans aucune formule ni format conditionnel (un comble dans notre tableur préféré
C'est fait, lors d'une modification de l'année du planning, la macro demande le N° du collaborateur ayant assuré l'astreinte de la semaine 52 ou 53 de l'année précédente. C'est ce n° qui est stocké en A7 (nom "Der_An_Préc"). Les astreintes sont évaluées sur toute l'année choisie, le planning affiché est, en quelque sorte, une fenêtre de 6 semaines sur cette année.
Cependant je n'ai pas pris en charge le RàZ de la zone de saisie lors ce changement d'année.
C'est fait, ou presque : la macro tient compte du nombre de collaborateurs dans la table "tb_Collaborateurs".
Elle redéfinit les noms "Planning_Collaborateurs" (zone d'affichage des absences par jour du planning et par collaborateur) et "ZoneSaisie" (zone de saisie des absences sur 12 périodes) et scrute ou remplit ces plages.
MAIS je n'ai pas pris en charge la modification de l'onglet Absence (ajout d'une ligne et de 14 lignes dans ces deux zones avec mise en forme etc. Ça pourrait faire l'objet d'un autre fil.
La macro se déclenche sur : un changement d'année ou de mois ; une modification dans la zone de saisie des dates d'absence.
Pour les formats (couleur de fond et de police) je me réfère à celles des tables "tb_Collaborateurs" et "tb_Type_Arrêt", tu peux les modifier si le cœur t'en dit. (cependant, tu devras adapter la mise en forme de l'onglet "absences" (liste des collaborateurs A10:A12 , et colonne A de la zone de saisie)
Voilà
Voir la pièce jointe
Ci-Après les noms utilisés et le code des 3 macros
Le tableaux structurés
tb_Année liste des années ( 11 années, commence à année courante - 4 -modifiable) tb_Mois liste des noms de mois tb_Collaborateurs liste des collaborateurs, avec couleur de fond et de police. tb_Type_Arrêt liste des motif d'arrêt, avec couleur de fond et de police. tb_Fériés Jours fériés sur 3 ans (commence à année choisie -1) automatique.
Les noms définis
Année =absence!$A$1 Année choisie Mois =absence!$A$2 Mois choisi DateDéb =absence!$A$4 Date de début sur le planning Der_An_Préc =absence!$A$7 N° du collaborateur qui a assuré la dernière astreinte de l'année précédente Limite =absence!$A$8 Nombre d'absences déclenchant l'alerte Fériés_An =Année+CHOISIR(NB.SI(Tables!$I$2:$I15;"Jour de l'an");-1;0;1) Année dans la table tb_Fériés, pour la calcul de pâques Pâques =SI(ET(Fériés_An>=1900;Fériés_An<=2204);
DATE(Fériés_An;3;29,56+0,979*MOD(204-11*MOD(Fériés_An;19);30)
-JOURSEM(DATE(Fériés_An;3;28,56+0,979*MOD(204-11*MOD(Fériés_An;19);30))));
"Hors domaine formule")Pâques en fonction de la position dans la table tb_Fériés Planning_Mois =absence!$B$1:$AQ$1 Ligne affichant le mois du planning Planning_Semaines =absence!$B$2:$AQ$2 Ligne affichant le N° de semaine du planning Planning_Curseur =absence!$B$3:$AQ$3 Ligne pour afficher le curseur sur la date d'aujourd'hui dans le planning Planning_Dates =absence!$B$4:$AQ$4 Ligne contenant le quantième du planning Planning_Jours =absence!$B$5:$AQ$5 Ligne contenant le jour de la semaine du planning Planning_Astreintes =absence!$B$6:$AQ$6 Ligne contenant le nom du collaborateur d'astreinte Planning_IdAstreintes =absence!$B$7:$AQ$7 Ligne contenant le N° du collaborateur d'astreinte Planning_Alertes =absence!$B$8:$AQ$8 Ligne affichant l'alerte si le nombre d'absences atteint la limite Planning_ComptageAbsences =absence!$B$9:$AQ$9 Ligne affichant le nombre d'absences pour chaque jour du planning Planning_Collaborateurs =absence!$B$10:$AQ$12 Zone contenant les motifs d'absence pour chaque jour et chaque collaborateur ZoneSaisie =absence!$B$13:$AE$54 Zone de saisie des absences
Code
Variables Public
VB:Const NbGpL As Byte = 2 'Nbr de grpe de lignes par collaborateur Const NbGpC As Byte = 6 'Nbr de grpe de colonnes par lignes de saisie Const NbSem As Byte = 6 'Nbr de semaine dans le planning Dim Arrêts, Collab, ZoneSaisie 'Tableaux des motifs d'arrêt, des collaborateurs, de la Zone de Saisie des absences Dim CoulArrêt, CoulCLB Dim NbCLB%, NbMA% 'Nbr collaborateurs, Nbr Motifs d'arrêt Dim DateDéb As Date, DateFin As Date 'Date de début et date de fin du planning affiché
Worksheet_Change
VB:Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Application.ScreenUpdating = False Collab = Tables.[tb_Collaborateurs].Value: NbCLB = UBound(Collab, 1) Arrêts = Tables.[tb_Type_Arrêt].Value: NbMA = UBound(Arrêts, 1) ReDim CoulCLB(1 To NbCLB, 1 To 2) ReDim CoulArrêt(1 To NbMA, 1 To 2) i = 0 For Each CLB In Tables.[tb_Collaborateurs] i = i + 1 CoulCLB(i, 1) = CLB.Interior.Color CoulCLB(i, 2) = CLB.Font.Color Next i = 0 For Each Arrêt In Tables.[tb_Type_Arrêt] i = i + 1 CoulArrêt(i, 1) = Arrêt.Interior.Color CoulArrêt(i, 2) = Arrêt.Font.Color Next 'Redéfinir les nom dépendant du Nbr Arrêts et du Nbr Collaborateurs With ThisWorkbook .Names("Planning_Collaborateurs").RefersTo = "=" & Me.[Planning_ComptageAbsences].Offset(1).Resize(NbCLB).Address .Names("ZoneSaisie").RefersTo = "=" & Me.[Planning_Collaborateurs].Offset(NbCLB).Resize((NbMA + 1) * NbGpL * NbCLB, NbGpC * 5).Address End With 'Aiguillage en fonction de la cellule modifiée Select Case True Case Target.Address = Me.[Année].Address Or Target.Address = Me.[Mois].Address If Target.Address = Me.[Année].Address Then Rép = Application.InputBox(Prompt:="N° du collaborateur ayant assuré l'astreinte de la dernière semaine de " & Me.[Année] - 1, _ Title:="Changement d'année", Type:=1) If Not TypeName(Rép) = "Booleen" Then Me.[Der_An_Préc] = Rép End If ChangePériode LireAbsences Case Not Intersect(Target, Me.[ZoneSaisie]) Is Nothing LireAbsences End Select Application.ScreenUpdating = True Application.EnableEvents = True End Sub
ChangePériode
VB:Sub ChangePériode() Dim tbD(0 To 1, 0 To NbSem * 7 - 1), tbM(0 To NbSem * 7 - 1) Dim Mois$, m As Byte, Année%, d Mois = Me.[Mois] Année = Me.[Année] d = CLng(DateValue("1 " & Mois & " " & Année)) '1er du mois en cours DateDébut = CDate(Evaluate(d & "+CHOOSE(WEEKDAY(" & d & ",2),0,-1,-2,-3,3,2,1)")) 'Début de la semaine contenant le début du mois en cours Me.[DateDéb] = DateDébut 'Début du planning affiché DateFin = DateDébut + (NbSem + 7) - 1 'Fin du planning Affiché 'Positionnement du curseur sur la date actuelle (si affichée) Me.[Planning_Curseur].Clear If Date >= DateDébut And Date <= DateFin Then With Me.[Planning_Curseur].Cells(Date - DateDébut + 1) .Font.Name = "Wingdings" .Font.Size = 14 .Font.Color = 16777215 .Interior.Color = 32768 .Value = "ê" .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End If 'Remise en forme du calendrier sur NbSem semaines 'Raz de la ligne Mois m = 0 Me.[Planning_Mois].ClearContents Me.[Planning_Mois].Borders.LineStyle = xlNone Me.[Planning_Mois].Borders(xlEdgeBottom).LineStyle = xlContinuous 'MàJ des quantièmes et des jours de la semaine With Me.[Planning_dates:Planning_jours] .Interior.Color = 16777215 .Font.Color = 0 'Boucle sur les NbSem*7 jours For i = 0 To NbSem * 7 - 1 d = DateDébut + i 'Réhaussement des jours fériés If Evaluate("OR(" & CLng(d) & "=Tb_Fériés[Date])") = True Then With .Cells(i + 1).Resize(2, 1) .Interior.Color = 5066944 .Font.Color = 16777215 End With End If 'Mémoriser le quantième et le jour de la semaine tbD(0, i) = Day(d) tbD(1, i) = UCase(Left(Format(d, "ddd"), 1)) 'Noter les changements de mois If Month(d) <> m Then m = Month(d) Me.[Planning_Mois].Cells(i + 1) = Format(d, "mmm-yy") Me.[Planning_Mois].Cells(i + 1).Borders(xlEdgeLeft).LineStyle = xlDouble End If Next i 'Ecrire les quantièmes et les jours de la semaine mémorisés .Value = tbD End With 'N° de semaine ISO pour les 6 semaines For i = 0 To 35 Step 7 Me.[Planning_Semaines].Cells(1, i + 1) = "S " & Evaluate("ISOWEEKNUM(" & CLng(DateDébut) + i & ")") Next End Sub
LireAbsences
VB:Sub LireAbsences() Dim I0, IX, Dmin, Dmax, CLB As Byte, Lgn% Mois = Me.[Mois] Année = Me.[Année] DateDéb = Me.[DateDéb].Value DateFin = DateDéb + (NbSem * 7) - 1 ZoneSaisie = Me.[ZoneSaisie].Value Dmin = 3000000: Dmax = 0 NbLgn = NbGpL * (NbMA) * NbGpC 'Lecture du tableau de saisie et calcul des durées des absences ReDim tbDéb(NbLgn, NbCLB), tbFin(NbLgn, NbCLB) For CLB = 1 To NbCLB For Lgn = 1 To NbLgn LAbs = (((CLB - 1) Mod NbCLB) * (NbMA + 1) * NbGpL) + (Int((Lgn - 1) / (NbMA * NbGpC)) + 1) + Int((Lgn - 1) / 6) + 1 CAbsN = ((Lgn - 1) Mod NbGpC) * 5 + 3 tbDéb(Lgn, CLB) = ZoneSaisie(LAbs, ((Lgn - 1) Mod NbGpC) * 5 + 1) tbFin(Lgn, CLB) = ZoneSaisie(LAbs, ((Lgn - 1) Mod NbGpC) * 5 + 4) If IsDate(tbDéb(Lgn, CLB)) And tbDéb(Lgn, CLB) < Dmin Then Dmin = tbDéb(Lgn, CLB) If IsDate(tbFin(Lgn, CLB)) And tbFin(Lgn, CLB) > Dmax Then Dmax = tbFin(Lgn, CLB) If IsDate(tbDéb(Lgn, CLB)) And IsDate(tbFin(Lgn, CLB)) Then ZoneSaisie(LAbs, CAbsN) = CLng(tbFin(Lgn, CLB)) - CLng(tbDéb(Lgn, CLB)) + 1 End If Next Lgn Next CLB Me.[ZoneSaisie].Value = ZoneSaisie 'Limites de la période globale (couvrant toutes les absences posées et l'année affichée) '1er jour de la semaine du début de la période globale I0 = CLng(DateSerial(Year(IIf(DateSerial(Année, 1, 1) < Dmin, DateValue("1 " & Mois & " " & Année), Dmin)), 1, 1)) I0 = CDate(Evaluate(I0 & "+CHOOSE(WEEKDAY(" & I0 & ",2),0,-1,-2,-3,3,2,1)")) 'Dernier jour de la semaine de la fin de la période globale IX = CLng(DateSerial(Année, 12, 1)) IX = CDate(Evaluate(IX & "+CHOOSE(WEEKDAY(" & I0 & ",2),0,-1,-2,-3,3,2,1)")) + NbSem * 7 - 1 IX = DateSerial(Year(IIf(IX > Dmax, IX, Dmax)), 12, 31) IX = IX - Weekday(IX, vbMonday) + IIf(WorksheetFunction.IsoWeekNum(IX) = 1, 0, 7) 'Remplissage du tableau global (sur toutes la période définie par les dates connues) ReDim tb_An(1 To NbCLB, 1 To CLng(IX - I0) + 1, 1 To 2) 'Tableau(nb collaborateur, nb jours de la période globale) pour recueillir les types d'arrêts ReDim tb_nbAbs(1 To 1, 1 To CLng(IX - I0) + 1) 'Tableau de comptage d'absences par jour sur la période globale For i = 1 To UBound(tb_nbAbs, 2): tb_nbAbs(1, i) = 0: Next i 'Initialisation à 0 For CLB = 1 To NbCLB 'Boucle sur le nbr de collaborateurs For Lgn = 1 To NbLgn 'Boucle sur le nombre de lignes par collaborateur If Not (IsEmpty(tbDéb(Lgn, CLB)) Or IsEmpty(tbFin(Lgn, CLB))) Then Idx = (Lgn - 1) Mod NbMA + 1 Arrêt = Arrêts(Idx, 1) 'Type d'arrêt en fonction du N° de la ligne courante For d = CLng(tbDéb(Lgn, CLB) - I0 + 1) To CLng(tbFin(Lgn, CLB) - I0 + 1) 'Boucle sur les dates de la période d'absence tb_An(CLB, d, 1) = Arrêt 'Type d'arrêt tb_An(CLB, d, 2) = Idx 'Type d'arrêt tb_nbAbs(1, d) = tb_nbAbs(1, d) + 1 'Cumul du nombre d'absences pour la date d Next End If Next Next 'Remplissage du tableau des types d'absence pour les dates affichées du planning ReDim Tb_Abs(1 To NbCLB, 1 To CLng(DateFin - DateDéb + 1)) ReDim Tb_cumul(1 To 1, 1 To CLng(DateFin - DateDéb + 1)) Limite = Me.[Limite].Value Col = 0 For d = CLng(DateDéb - I0 + 1) To CLng(DateFin - I0 + 1) Col = Col + 1 For CLB = 1 To NbCLB Tb_Abs(CLB, Col) = tb_An(CLB, d, 1) If Tb_Abs(CLB, Col) <> "" Then Me.[Planning_Collaborateurs].Cells(CLB, Col).Interior.Color = CoulArrêt(tb_An(CLB, d, 2), 1) Me.[Planning_Collaborateurs].Cells(CLB, Col).Font.Color = CoulArrêt(tb_An(CLB, d, 2), 2) Else Me.[Planning_Collaborateurs].Cells(CLB, Col).Interior.Color = 16777215 Me.[Planning_Collaborateurs].Cells(CLB, Col).Font.Color = 0 End If Next Tb_cumul(1, Col) = tb_nbAbs(1, d) Me.[Planning_Alertes].Cells(Col).Font.Color = IIf(Tb_cumul(1, Col) >= Limite, 255, 32768) Next Me.[Planning_Collaborateurs].Value = Tb_Abs Me.[Planning_ComptageAbsences].Value = Tb_cumul 'Dates de l'année suivie 'Premier jour de la semaine 1 JDéb = CLng(DateSerial(Année, 1, 1)) JDéb = CDate(Evaluate(JDéb & "+CHOOSE(WEEKDAY(" & JDéb & ",2),0,-1,-2,-3,3,2,1)")) 'Dernier jour du planning pour le mois de décembre JFin = CLng(DateSerial(Année, 12, 1)) JFin = CDate(Evaluate(JFin & "+CHOOSE(WEEKDAY(" & JFin & ",2),0,-1,-2,-3,3,2,1)")) + NbSem * 7 - 1 ReDim tbAstr(1 To JFin - JDéb + 1) Dd = JDéb - I0 N° = Me.[Der_An_Préc].Value For DLun = 0 To JFin - JDéb - 6 Step 7 Trouvé = 0 For n = 0 To NbCLB - 1 AbsSem = "" CLB = (N° + n) Mod NbCLB + 1 For j = 1 To 7 Idx = Dd + DLun + j AbsSem = AbsSem & tb_An(CLB, Idx, 1) Next j If AbsSem = "" Then Trouvé = CLB Exit For End If Next n N° = Trouvé For j = 1 To 7 tbAstr(DLun + j) = N° Next j Next DLun ReDim tb1(1 To 1, 1 To NbSem * 7) ReDim tb2(1 To 1, 1 To NbSem * 7) Déb = CLng(DateDéb - JDéb) With Me.[Planning_Astreintes] For j = 1 To 42 tb1(1, j) = tbAstr(Déb + j) If tb1(1, j) <> 0 Then tb2(1, j) = WorksheetFunction.Index(Collab, tb1(1, j), 1) .Cells(j).Interior.Color = CoulCLB(tb1(1, j), 1) .Cells(j).Font.Color = CoulCLB(tb1(1, j), 2) Else .Cells(j).Interior.Color = 16777215 .Cells(j).Font.Color = 0 End If Next .Value = tb2 End With Me.[Planning_IdAstreintes].Value = tb1 End Sub
Bonsoir à toutes & à tous,
bonsoir @chich
Bon c'est la saison des travaux d'extérieurs, ça me ralenti (moi qui ne suis déjà pas rapide
Je crois que j'ai abouti : une feuille sans aucune formule ni format conditionnel (un comble dans notre tableur préféré
C'est fait, lors d'une modification de l'année du planning, la macro demande le N° du collaborateur ayant assuré l'astreinte de la semaine 52 ou 53 de l'année précédente. C'est ce n° qui est stocké en A7 (nom "Der_An_Préc"). Les astreintes sont évaluées sur toute l'année choisie, le planning affiché est, en quelque sorte, une fenêtre de 6 semaines sur cette année.
Cependant je n'ai pas pris en charge le RàZ de la zone de saisie lors ce changement d'année.
C'est fait, ou presque : la macro tient compte du nombre de collaborateurs dans la table "tb_Collaborateurs".
Elle redéfinit les noms "Planning_Collaborateurs" (zone d'affichage des absences par jour du planning et par collaborateur) et "ZoneSaisie" (zone de saisie des absences sur 12 périodes) et scrute ou remplit ces plages.
MAIS je n'ai pas pris en charge la modification de l'onglet Absence (ajout d'une ligne et de 14 lignes dans ces deux zones avec mise en forme etc. Ça pourrait faire l'objet d'un autre fil.
La macro se déclenche sur : un changement d'année ou de mois ; une modification dans la zone de saisie des dates d'absence.
Pour les formats (couleur de fond et de police) je me réfère à celles des tables "tb_Collaborateurs" et "tb_Type_Arrêt", tu peux les modifier si le cœur t'en dit. (cependant, tu devras adapter la mise en forme de l'onglet "absences" (liste des collaborateurs A10:A12 , et colonne A de la zone de saisie)
Voilà
Voir la pièce jointe
Ci-Après les noms utilisés et le code des 3 macros
Le tableaux structurés
tb_Année liste des années ( 11 années, commence à année courante - 4 -modifiable) tb_Mois liste des noms de mois tb_Collaborateurs liste des collaborateurs, avec couleur de fond et de police. tb_Type_Arrêt liste des motif d'arrêt, avec couleur de fond et de police. tb_Fériés Jours fériés sur 3 ans (commence à année choisie -1) automatique.
Les noms définis
Année =absence!$A$1 Année choisie Mois =absence!$A$2 Mois choisi DateDéb =absence!$A$4 Date de début sur le planning Der_An_Préc =absence!$A$7 N° du collaborateur qui a assuré la dernière astreinte de l'année précédente Limite =absence!$A$8 Nombre d'absences déclenchant l'alerte Fériés_An =Année+CHOISIR(NB.SI(Tables!$I$2:$I15;"Jour de l'an");-1;0;1) Année dans la table tb_Fériés, pour la calcul de pâques Pâques =SI(ET(Fériés_An>=1900;Fériés_An<=2204);
DATE(Fériés_An;3;29,56+0,979*MOD(204-11*MOD(Fériés_An;19);30)
-JOURSEM(DATE(Fériés_An;3;28,56+0,979*MOD(204-11*MOD(Fériés_An;19);30))));
"Hors domaine formule")Pâques en fonction de la position dans la table tb_Fériés Planning_Mois =absence!$B$1:$AQ$1 Ligne affichant le mois du planning Planning_Semaines =absence!$B$2:$AQ$2 Ligne affichant le N° de semaine du planning Planning_Curseur =absence!$B$3:$AQ$3 Ligne pour afficher le curseur sur la date d'aujourd'hui dans le planning Planning_Dates =absence!$B$4:$AQ$4 Ligne contenant le quantième du planning Planning_Jours =absence!$B$5:$AQ$5 Ligne contenant le jour de la semaine du planning Planning_Astreintes =absence!$B$6:$AQ$6 Ligne contenant le nom du collaborateur d'astreinte Planning_IdAstreintes =absence!$B$7:$AQ$7 Ligne contenant le N° du collaborateur d'astreinte Planning_Alertes =absence!$B$8:$AQ$8 Ligne affichant l'alerte si le nombre d'absences atteint la limite Planning_ComptageAbsences =absence!$B$9:$AQ$9 Ligne affichant le nombre d'absences pour chaque jour du planning Planning_Collaborateurs =absence!$B$10:$AQ$12 Zone contenant les motifs d'absence pour chaque jour et chaque collaborateur ZoneSaisie =absence!$B$13:$AE$54 Zone de saisie des absences
Code
Variables Public
VB:Const NbGpL As Byte = 2 'Nbr de grpe de lignes par collaborateur Const NbGpC As Byte = 6 'Nbr de grpe de colonnes par lignes de saisie Const NbSem As Byte = 6 'Nbr de semaine dans le planning Dim Arrêts, Collab, ZoneSaisie 'Tableaux des motifs d'arrêt, des collaborateurs, de la Zone de Saisie des absences Dim CoulArrêt, CoulCLB Dim NbCLB%, NbMA% 'Nbr collaborateurs, Nbr Motifs d'arrêt Dim DateDéb As Date, DateFin As Date 'Date de début et date de fin du planning affiché
Worksheet_Change
VB:Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Application.ScreenUpdating = False Collab = Tables.[tb_Collaborateurs].Value: NbCLB = UBound(Collab, 1) Arrêts = Tables.[tb_Type_Arrêt].Value: NbMA = UBound(Arrêts, 1) ReDim CoulCLB(1 To NbCLB, 1 To 2) ReDim CoulArrêt(1 To NbMA, 1 To 2) i = 0 For Each CLB In Tables.[tb_Collaborateurs] i = i + 1 CoulCLB(i, 1) = CLB.Interior.Color CoulCLB(i, 2) = CLB.Font.Color Next i = 0 For Each Arrêt In Tables.[tb_Type_Arrêt] i = i + 1 CoulArrêt(i, 1) = Arrêt.Interior.Color CoulArrêt(i, 2) = Arrêt.Font.Color Next 'Redéfinir les nom dépendant du Nbr Arrêts et du Nbr Collaborateurs With ThisWorkbook .Names("Planning_Collaborateurs").RefersTo = "=" & Me.[Planning_ComptageAbsences].Offset(1).Resize(NbCLB).Address .Names("ZoneSaisie").RefersTo = "=" & Me.[Planning_Collaborateurs].Offset(NbCLB).Resize((NbMA + 1) * NbGpL * NbCLB, NbGpC * 5).Address End With 'Aiguillage en fonction de la cellule modifiée Select Case True Case Target.Address = Me.[Année].Address Or Target.Address = Me.[Mois].Address If Target.Address = Me.[Année].Address Then Rép = Application.InputBox(Prompt:="N° du collaborateur ayant assuré l'astreinte de la dernière semaine de " & Me.[Année] - 1, _ Title:="Changement d'année", Type:=1) If Not TypeName(Rép) = "Booleen" Then Me.[Der_An_Préc] = Rép End If ChangePériode LireAbsences Case Not Intersect(Target, Me.[ZoneSaisie]) Is Nothing LireAbsences End Select Application.ScreenUpdating = True Application.EnableEvents = True End Sub
ChangePériode
VB:Sub ChangePériode() Dim tbD(0 To 1, 0 To NbSem * 7 - 1), tbM(0 To NbSem * 7 - 1) Dim Mois$, m As Byte, Année%, d Mois = Me.[Mois] Année = Me.[Année] d = CLng(DateValue("1 " & Mois & " " & Année)) '1er du mois en cours DateDébut = CDate(Evaluate(d & "+CHOOSE(WEEKDAY(" & d & ",2),0,-1,-2,-3,3,2,1)")) 'Début de la semaine contenant le début du mois en cours Me.[DateDéb] = DateDébut 'Début du planning affiché DateFin = DateDébut + (NbSem + 7) - 1 'Fin du planning Affiché 'Positionnement du curseur sur la date actuelle (si affichée) Me.[Planning_Curseur].Clear If Date >= DateDébut And Date <= DateFin Then With Me.[Planning_Curseur].Cells(Date - DateDébut + 1) .Font.Name = "Wingdings" .Font.Size = 14 .Font.Color = 16777215 .Interior.Color = 32768 .Value = "ê" .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End If 'Remise en forme du calendrier sur NbSem semaines 'Raz de la ligne Mois m = 0 Me.[Planning_Mois].ClearContents Me.[Planning_Mois].Borders.LineStyle = xlNone Me.[Planning_Mois].Borders(xlEdgeBottom).LineStyle = xlContinuous 'MàJ des quantièmes et des jours de la semaine With Me.[Planning_dates:Planning_jours] .Interior.Color = 16777215 .Font.Color = 0 'Boucle sur les NbSem*7 jours For i = 0 To NbSem * 7 - 1 d = DateDébut + i 'Réhaussement des jours fériés If Evaluate("OR(" & CLng(d) & "=Tb_Fériés[Date])") = True Then With .Cells(i + 1).Resize(2, 1) .Interior.Color = 5066944 .Font.Color = 16777215 End With End If 'Mémoriser le quantième et le jour de la semaine tbD(0, i) = Day(d) tbD(1, i) = UCase(Left(Format(d, "ddd"), 1)) 'Noter les changements de mois If Month(d) <> m Then m = Month(d) Me.[Planning_Mois].Cells(i + 1) = Format(d, "mmm-yy") Me.[Planning_Mois].Cells(i + 1).Borders(xlEdgeLeft).LineStyle = xlDouble End If Next i 'Ecrire les quantièmes et les jours de la semaine mémorisés .Value = tbD End With 'N° de semaine ISO pour les 6 semaines For i = 0 To 35 Step 7 Me.[Planning_Semaines].Cells(1, i + 1) = "S " & Evaluate("ISOWEEKNUM(" & CLng(DateDébut) + i & ")") Next End Sub
LireAbsences
VB:Sub LireAbsences() Dim I0, IX, Dmin, Dmax, CLB As Byte, Lgn% Mois = Me.[Mois] Année = Me.[Année] DateDéb = Me.[DateDéb].Value DateFin = DateDéb + (NbSem * 7) - 1 ZoneSaisie = Me.[ZoneSaisie].Value Dmin = 3000000: Dmax = 0 NbLgn = NbGpL * (NbMA) * NbGpC 'Lecture du tableau de saisie et calcul des durées des absences ReDim tbDéb(NbLgn, NbCLB), tbFin(NbLgn, NbCLB) For CLB = 1 To NbCLB For Lgn = 1 To NbLgn LAbs = (((CLB - 1) Mod NbCLB) * (NbMA + 1) * NbGpL) + (Int((Lgn - 1) / (NbMA * NbGpC)) + 1) + Int((Lgn - 1) / 6) + 1 CAbsN = ((Lgn - 1) Mod NbGpC) * 5 + 3 tbDéb(Lgn, CLB) = ZoneSaisie(LAbs, ((Lgn - 1) Mod NbGpC) * 5 + 1) tbFin(Lgn, CLB) = ZoneSaisie(LAbs, ((Lgn - 1) Mod NbGpC) * 5 + 4) If IsDate(tbDéb(Lgn, CLB)) And tbDéb(Lgn, CLB) < Dmin Then Dmin = tbDéb(Lgn, CLB) If IsDate(tbFin(Lgn, CLB)) And tbFin(Lgn, CLB) > Dmax Then Dmax = tbFin(Lgn, CLB) If IsDate(tbDéb(Lgn, CLB)) And IsDate(tbFin(Lgn, CLB)) Then ZoneSaisie(LAbs, CAbsN) = CLng(tbFin(Lgn, CLB)) - CLng(tbDéb(Lgn, CLB)) + 1 End If Next Lgn Next CLB Me.[ZoneSaisie].Value = ZoneSaisie 'Limites de la période globale (couvrant toutes les absences posées et l'année affichée) '1er jour de la semaine du début de la période globale I0 = CLng(DateSerial(Year(IIf(DateSerial(Année, 1, 1) < Dmin, DateValue("1 " & Mois & " " & Année), Dmin)), 1, 1)) I0 = CDate(Evaluate(I0 & "+CHOOSE(WEEKDAY(" & I0 & ",2),0,-1,-2,-3,3,2,1)")) 'Dernier jour de la semaine de la fin de la période globale IX = CLng(DateSerial(Année, 12, 1)) IX = CDate(Evaluate(IX & "+CHOOSE(WEEKDAY(" & I0 & ",2),0,-1,-2,-3,3,2,1)")) + NbSem * 7 - 1 IX = DateSerial(Year(IIf(IX > Dmax, IX, Dmax)), 12, 31) IX = IX - Weekday(IX, vbMonday) + IIf(WorksheetFunction.IsoWeekNum(IX) = 1, 0, 7) 'Remplissage du tableau global (sur toutes la période définie par les dates connues) ReDim tb_An(1 To NbCLB, 1 To CLng(IX - I0) + 1, 1 To 2) 'Tableau(nb collaborateur, nb jours de la période globale) pour recueillir les types d'arrêts ReDim tb_nbAbs(1 To 1, 1 To CLng(IX - I0) + 1) 'Tableau de comptage d'absences par jour sur la période globale For i = 1 To UBound(tb_nbAbs, 2): tb_nbAbs(1, i) = 0: Next i 'Initialisation à 0 For CLB = 1 To NbCLB 'Boucle sur le nbr de collaborateurs For Lgn = 1 To NbLgn 'Boucle sur le nombre de lignes par collaborateur If Not (IsEmpty(tbDéb(Lgn, CLB)) Or IsEmpty(tbFin(Lgn, CLB))) Then Idx = (Lgn - 1) Mod NbMA + 1 Arrêt = Arrêts(Idx, 1) 'Type d'arrêt en fonction du N° de la ligne courante For d = CLng(tbDéb(Lgn, CLB) - I0 + 1) To CLng(tbFin(Lgn, CLB) - I0 + 1) 'Boucle sur les dates de la période d'absence tb_An(CLB, d, 1) = Arrêt 'Type d'arrêt tb_An(CLB, d, 2) = Idx 'Type d'arrêt tb_nbAbs(1, d) = tb_nbAbs(1, d) + 1 'Cumul du nombre d'absences pour la date d Next End If Next Next 'Remplissage du tableau des types d'absence pour les dates affichées du planning ReDim Tb_Abs(1 To NbCLB, 1 To CLng(DateFin - DateDéb + 1)) ReDim Tb_cumul(1 To 1, 1 To CLng(DateFin - DateDéb + 1)) Limite = Me.[Limite].Value Col = 0 For d = CLng(DateDéb - I0 + 1) To CLng(DateFin - I0 + 1) Col = Col + 1 For CLB = 1 To NbCLB Tb_Abs(CLB, Col) = tb_An(CLB, d, 1) If Tb_Abs(CLB, Col) <> "" Then Me.[Planning_Collaborateurs].Cells(CLB, Col).Interior.Color = CoulArrêt(tb_An(CLB, d, 2), 1) Me.[Planning_Collaborateurs].Cells(CLB, Col).Font.Color = CoulArrêt(tb_An(CLB, d, 2), 2) Else Me.[Planning_Collaborateurs].Cells(CLB, Col).Interior.Color = 16777215 Me.[Planning_Collaborateurs].Cells(CLB, Col).Font.Color = 0 End If Next Tb_cumul(1, Col) = tb_nbAbs(1, d) Me.[Planning_Alertes].Cells(Col).Font.Color = IIf(Tb_cumul(1, Col) >= Limite, 255, 32768) Next Me.[Planning_Collaborateurs].Value = Tb_Abs Me.[Planning_ComptageAbsences].Value = Tb_cumul 'Dates de l'année suivie 'Premier jour de la semaine 1 JDéb = CLng(DateSerial(Année, 1, 1)) JDéb = CDate(Evaluate(JDéb & "+CHOOSE(WEEKDAY(" & JDéb & ",2),0,-1,-2,-3,3,2,1)")) 'Dernier jour du planning pour le mois de décembre JFin = CLng(DateSerial(Année, 12, 1)) JFin = CDate(Evaluate(JFin & "+CHOOSE(WEEKDAY(" & JFin & ",2),0,-1,-2,-3,3,2,1)")) + NbSem * 7 - 1 ReDim tbAstr(1 To JFin - JDéb + 1) Dd = JDéb - I0 N° = Me.[Der_An_Préc].Value For DLun = 0 To JFin - JDéb - 6 Step 7 Trouvé = 0 For n = 0 To NbCLB - 1 AbsSem = "" CLB = (N° + n) Mod NbCLB + 1 For j = 1 To 7 Idx = Dd + DLun + j AbsSem = AbsSem & tb_An(CLB, Idx, 1) Next j If AbsSem = "" Then Trouvé = CLB Exit For End If Next n N° = Trouvé For j = 1 To 7 tbAstr(DLun + j) = N° Next j Next DLun ReDim tb1(1 To 1, 1 To NbSem * 7) ReDim tb2(1 To 1, 1 To NbSem * 7) Déb = CLng(DateDéb - JDéb) With Me.[Planning_Astreintes] For j = 1 To 42 tb1(1, j) = tbAstr(Déb + j) If tb1(1, j) <> 0 Then tb2(1, j) = WorksheetFunction.Index(Collab, tb1(1, j), 1) .Cells(j).Interior.Color = CoulCLB(tb1(1, j), 1) .Cells(j).Font.Color = CoulCLB(tb1(1, j), 2) Else .Cells(j).Interior.Color = 16777215 .Cells(j).Font.Color = 0 End If Next .Value = tb2 End With Me.[Planning_IdAstreintes].Value = tb1 End Sub
Bonjour AtTheOne
Je reviens vers toi pour savoir comment adapter ta macro pour alimenter la feuille Plag dans le fichier jointpour finalisé mon projet ca va me libérer du temps au quotidien.
Exemple le 01/01/2020
Merci d'avance
Discussions similaires
- Question
- Résolu(e)
Microsoft 365
Conserver lien hypertexte avec une fonction RechercheV
Membres actuellement en ligne
Aucun membre en ligne actuellement.
