XL 2019 Remplacer des formules par une macro

[chich]

Bonjour a tous
Je cherche une macro pour faire le job de toutes les formules et les MFC de la feuil absence dans le fichier joint.
Merci d'avance

 

[AtTheOne]

Bonsoir à toutes et à tous,
bonsoir @chich

D'autres au contraire prennent une autre proposition que la leur comme un affront.

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 ...

 

[TooFatBoy]

Et d'autres préfèrent ne pas froisser ceux qui se sont investis

Oui, tout à fait. C'est exactement ce que ma réponse sous-entendait. Nous sommes parfaitement d'accord.

 

[chich]

Bonsoir à 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 ...

Re
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

 

[AtTheOne]

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é !)

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 ?

il faut tenir compte de la dernière semaine de l'année précédente

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.

garder la possibilité de pouvoir ajouter des collaborateurs si l'équipe s'agrandi

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

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

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

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

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

 

[chich]

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

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

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

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

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
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

 

[AtTheOne]

Bonsoir à toutes & à tous,
bonsoir @chich

Ou je peux définir par exemple les 3 premier qui peuvent prendre le toure de permanence
dans la liste des collaborateurs

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

dans le fichier démo anonymisé que j'ai joint
ce nombre et en A6

Je n'ai pas ce fichier joint ???
A bientôt

 

[chich]

Bonsoir à toutes & à tous,
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

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

 

[AtTheOne]

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

 

[AtTheOne]

Re
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.

 

[AtTheOne]

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)

 

[chich]

Re
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 de collaborateurs ou pour les n premiers assurant l'astreinte ?​

Je penche pour le deuxième cas, mais je préfère que tu me confirme.

Re
2 c'est pour le nombre max de tous les collaborateurs en absence

 

[AtTheOne]

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 !

 

[chich]

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

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

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

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

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

 

[chich]

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

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

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

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

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 joint
pour finalisé mon projet ca va me libérer du temps au quotidien.
Exemple le 01/01/2020
Merci d'avance

 

[AtTheOne]

Bonsoir @chich
Je n'ai pas de PC en ce moment, il va falloir attendre un peu ... car sur mon téléphone ce n'est pas possible !