'=========================================================================================
'Lire les absences dans la feuille planning et les écrire dans les plannings hebdomadaires
'=========================================================================================
Sub LireAbsencesH()
'Mémorisation des états avant la procédure
EtatEvénements = Application.EnableEvents
EtatScreen = Application.ScreenUpdating
EtatCalcul = Application.Calculation
'Geler calculs, gestion des évènements, mise à jour de l'affichage
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Mois = Plgn_Hebdo.[Mois_H].Value 'Le mois lu sur la feuille Plgn_Hebo
Année = Plgn_Hebdo.[Année_H].Value 'L'année lue sur la feuille Plgn_Hebo
NbCLB = Tables.[tb_Collaborateurs].Rows.Count 'Nb de collaborateurs
Arrêts = Tables.[tb_Type_Arrêt].Value: NbMA = UBound(Arrêts, 1) 'Liste des motifs d'arrêt et nb de ces motifs
'Lecture des couleurs à appliquer
ReDim CoulArrêt(1 To NbMA, 1 To 2)
Dim CoulRepos(1 To 2)
Dim CoulFérié(1 To 2)
'Les motifs d'arrêt
i = 0
For Each Arrêtc In Tables.[tb_Type_Arrêt]
i = i + 1
CoulArrêt(i, 1) = Arrêtc.Interior.Color
CoulArrêt(i, 2) = Arrêtc.Font.Color
Next
'Les jours de repos
With Tables.[Couleurs_ReposH]
CoulRepos(1) = .Interior.Color
CoulRepos(2) = .Font.Color
End With
'Couleurs pour les jours fériés
With Tables.[Couleurs_Férié]
CoulFérié(1) = .Interior.Color
CoulFérié(2) = .Font.Color
End With
'Lecture des absences saisies sur le planning d'absence
ZoneSaisie = Planning.[ZoneSaisie].Value
'Bornes pour les semaines affichées
'1er du mois en cours et N° du jour de la semaine
d = DateValue("1 " & Mois & " " & Année): N°J = Weekday(d, vbMonday)
'Début de la semaine contenant le début du mois en cours
DateDéb = d + Evaluate("CHOOSE(" & N°J & ",-7,-1,-2,-3,-4,-5,-6)")
'Fin de la dernière Semaine affichée pour le mois en cours
DateFin = DateDéb + NbSemH * 7 - 1
'Lecture des absences saisies (Feuille Planning)
'Nbre de saisies d'absence possibles par CoLlaBorateur : Nb de Motif d'Arrêt * Nb de Gpe de ligne * Nb Grp de colonnes
NbLgn = NbMA * NbGpL * NbGpC
'Tableau limité aux saisies possible
ReDim TbSaisies(1 To NbCLB, 1 To NbLgn, 1 To 3)
'Nbre de lignes de lecture de la données dans la Zone de saisie (comprend les lignes de présentation)
LgnParCLBLec = NbGpL * (NbMA + 1)
'Pour chaque CoLlaBorateur
For CLB = 1 To NbCLB
'Pour chaque gpe de lignes de motifs d'absence (dans le tableau exemple il y a 2 gpes de lignes pour saisir le absences)
For GpLgn = 1 To NbGpL
'Décalage de la première ligne dans le tableau d'écriture pour ce gpe de ligne
GpLgn0 = (GpLgn - 1) * NbMA * NbGpC '1 gpe de lignes contient NbMA lignes de motifs d'absence
'Pour chaque motif d'absence dans le gpe de lignes
For Lgn = 1 To NbMA
'N° de la ligne pour lire dans la zone de saisie brute (en tenant compte des lignes de présentation)
LigneLecture = NbMA * (GpLgn - 1) + GpLgn + Lgn + (CLB - 1) * LgnParCLBLec
'Pour chaque description d'absence dans la ligne
For GpCol = 1 To NbGpC
'N° de la ligne pour écrire dans le tableau TbSaisies
ligneEcriture = GpLgn0 + (Lgn - 1) * NbGpC + GpCol 'chaque ligne de motif d'absence contient NbGpC descriptions d'absence
'valeur pouvant comprendre une date de début
TbSaisies(CLB, ligneEcriture, 1) = ZoneSaisie(LigneLecture, (GpCol - 1) * 5 + 1)
'valeur pouvant comprendre une date de fin
TbSaisies(CLB, ligneEcriture, 2) = ZoneSaisie(LigneLecture, (GpCol - 1) * 5 + 4)
'N° de la ligne donnant l'index du Motif d'absence
TbSaisies(CLB, ligneEcriture, 3) = Lgn
Next GpCol
Next Lgn
Next GpLgn
Next CLB
'Maintenant le tableau TbSaisie contient, par collaborateur, les plages de saisie de la zone de saisie (3 données par plage : début, fin, index du motif d'arrêt)
'Lecture des horaires des collaborateurs)
'tableau par collaborateur et jour de la semaine
ReDim TbHoraires(1 To NbCLB, 1 To 7)
'Lecture des horaires hebdomadaire dans la feuille Tables
TbHrr = Tables.[tb_Collaborateurs[[Lundi M]:[Dimanche A]]]
For CLB = 1 To NbCLB: For J = 1 To 14 Step 2
HM = TbHrr(CLB, J): HF = TbHrr(CLB, J + 1)
If IsNumeric(HM) And IsNumeric(HF) Then
'Le jour contient un horaire de début et de fin
TbHoraires(CLB, (J + 1) / 2) = Format(HM, "hh:mm") & " à " & Format(HF, "hh:mm")
Else
'Il s'agit d'un jour de repos (Matin et AM supposés identiques)
TbHoraires(CLB, (J + 1) / 2) = HM
End If
Next J: Next CLB
'Maintenant le tableau TbHoraires contient pour chaque collaborateur sa plage horaire ou "Repos H" (valeur de la table)
'Lecture pour chaque jour de la période suivie des absences
ReDim tbABS(1 To NbCLB, DateDéb To DateFin)
'Pour chaque collaborateur, on va stocker soit l'horaire, soit Repos H, soit Férié dans le tableau TbAbs
ReDim TbIdxMA(1 To NbCLB, DateDéb To DateFin, 1 To 2)
'Et on va mémoriser les couleurs à appliquer
'Pour chaque collaborateur
For CLB = 1 To NbCLB
'Par défaut TbABS contient les Plages horaire, Férié ou Repos H
For J = DateDéb To DateFin
tbABS(CLB, J) = TbHoraires(CLB, Weekday(J, vbMonday))
If Evaluate("OR(" & CLng(J) & "=Tb_Fériés[Date])") Then
'Si J est un jour férié
tbABS(CLB, J) = "Férié"
TbIdxMA(CLB, J, 1) = CoulFérié(1) 'Couleur du fond
TbIdxMA(CLB, J, 2) = CoulFérié(2) 'Couleur de la police
ElseIf tbABS(CLB, J) = "Repos H" Then
'Si J est un jour de repos hebdomadaire
TbIdxMA(CLB, J, 1) = CoulRepos(1) 'Couleur du fond
TbIdxMA(CLB, J, 2) = CoulRepos(2) 'Couleur de la police
End If
Next J
'Pour saisie d'absence possible du collaborateur
For i = 1 To NbLgn
'(rappel 1 ligne de 3 valeurs pour chaque saisie possible : Jd =déb, Jf=fin, IdxMotif=idx du motif d'arrêt)
Jd = TbSaisies(CLB, i, 1): Jf = TbSaisies(CLB, i, 2): IdxMotif = TbSaisies(CLB, i, 3)
If IsDate(Jd) And IsDate(Jf) Then
'On a 2 DATES donc l'index d'un motif d'arrêt dans TbSaisies
If Jf >= DateDéb And Jd <= DateFin Then
'La plage de saisie chevauche le planning
For J = Jd To Jf
'pour chaque jour de la plage
If J >= DateDéb And J <= DateFin Then
'Le jour est inclus dans le planning
If Not IsEmpty(IdxMotif) And tbABS(CLB, J) <> "Repos H" And tbABS(CLB, J) <> "Férié" Then
'Vrai si il y a un motif d'arrêt en dehors de jours non travaillés (déjà renseigné pour Férié et Repos H)
'Stockage du motif d'arrêt
tbABS(CLB, J) = Arrêts(IdxMotif, 1)
'Stockage de la mise en couleur
TbIdxMA(CLB, J, 1) = CoulArrêt(IdxMotif, 1) 'Couleur fond
TbIdxMA(CLB, J, 2) = CoulArrêt(IdxMotif, 2) 'Couleur police
End If
End If
Next J
End If
End If
Next i
Next CLB
'Maintenant TbABS contient pour chaque collaborateur et pour chaque jour du planning
'soit Férié soit Repos H soit motif d'absence soit plage horaire ainsi que les couleurs à appliquer
ReDim TbHoraires(1 To NbCLB, 1 To 14)
'On va placer dans TbHoraires Les absences ou les plages horaire (TbHoraires recouvre 1 semaine avec 2 cellules par jour)
For Sem = 1 To NbSemH 'boucle sur chaque semaine du planning Hebdo
For CLB = 1 To NbCLB
For J = 1 To 7 'Boucle sur chaque jour de la semaine
'Date correspondant au jour de la semaine
DateJ = (Sem - 1) * 7 + DateDéb + J - 1
'Information correspondant au jour de cette semaine (plage horaire, repos H, férié, Motif d'absence)
If InStr(1, tbABS(CLB, DateJ), " à ", vbTextCompare) > 0 Then
'il s'agit d'un horaire (écrit sous la forme hh:mm à hh;mm)
ArrDép = Split(tbABS(CLB, DateJ), " à ")
TbHoraires(CLB, 1 + (J - 1) * 2) = CDbl(CDate(ArrDép(0)))
TbHoraires(CLB, 2 + (J - 1) * 2) = CDbl(CDate(ArrDép(1)))
Else
'Il s'agit d'une absence
TbHoraires(CLB, 1 + (J - 1) * 2) = tbABS(CLB, DateJ)
TbHoraires(CLB, 2 + (J - 1) * 2) = Empty
End If 'Si pour cette date on a une couleur définie (Motif d'arrêt ou Repos H)
If Not IsEmpty(TbIdxMA(CLB, DateJ, 1)) Then
'TbIdxMA(CLB, DateJ, 1) a été renseigné il faut fusionner les cellules de ce jour
'et appliquer les couleurs de fond et de police
With Plgn_Hebdo.[Date_J].Offset(3 + (Sem - 1) * (NbCLB + 4) + CLB - 1, (J - 1) * 2).Resize(1, 2)
.Merge
.Interior.Color = TbIdxMA(CLB, DateJ, 1)
.Font.Color = TbIdxMA(CLB, DateJ, 2)
End With
End If
Next J
Next CLB
'On remplit la semaine avec le tableau constitué
Plgn_Hebdo.[Date_J].Offset(3 + (Sem - 1) * (NbCLB + 4)).Resize(NbCLB).Value = TbHoraires
Next Sem
'Rétablir les états initiaux
With Application
.CutCopyMode = False
.EnableEvents = EtatEvénements
.ScreenUpdating = EtatScreen
.Calculation = EtatCalcul
End With
End Sub