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