XL 2019 Remplacer des formules par une macro
- Initiateur de la discussion chich
- Date de début
Solution
Re,
Juste une petite question :
L'horaire hebdomadaire des collaborateurs est-il fixe sur l'année ou variable chaque semaine ?
Car j'ai supposé qu'il était fixe et j'utilise une table dans la feuille Tables pour les lire. S'il est variable chaque semaine et que tu dois le saisir à quoi bon l'initialiser à 10:30 17:30 ?
À bientôt
Juste une petite question :
L'horaire hebdomadaire des collaborateurs est-il fixe sur l'année ou variable chaque semaine ?
Car j'ai supposé qu'il était fixe et j'utilise une table dans la feuille Tables pour les lire. S'il est variable chaque semaine et que tu dois le saisir à quoi bon l'initialiser à 10:30 17:30 ?
À bientôt
Re
oui les horaires sont très très variables par contre initialiser les horaires est intéressant pour moi
car sa me donne la possibilité de créer des semaines types
Re, re
Je suis toujours réticent pour modifier les macros d'autant plus que pour tes formules de calcul je peux te proposer plus simple (formules matricielle validées par CTRL MAJ Entrée) :
La 1ère semaine s'étendant sur la plage A2:H17
Cumul de la semaine pour le collaborateur 1 ligne 3
(les accolades sont mises par Excel lors de la validation.)
Sous total de la première semaine ligne 2
Cumul des 6 semaines ligne 1
Maintenant si tu ne veux absolument pas de cette solution, je te laisse faire un peu de développement par toi même
avant de m'y remettre.
À bientôt
Je suis toujours réticent pour modifier les macros d'autant plus que pour tes formules de calcul je peux te proposer plus simple (formules matricielle validées par CTRL MAJ Entrée) :
La 1ère semaine s'étendant sur la plage A2:H17
Cumul de la semaine pour le collaborateur 1 ligne 3
Enrichi (BBcode):
{=SOMME(SI(SIERREUR(TROUVE(" à ";B3:H3;1);0);CNUM(STXT(B3:H3;9;5))-CNUM(STXT(B3:H3;1;5));0))}Sous total de la première semaine ligne 2
Enrichi (BBcode):
=SOUS.TOTAL(9;I3:I17)
Enrichi (BBcode):
=SOUS.TOTAL(9;I2:I97)Maintenant si tu ne veux absolument pas de cette solution, je te laisse faire un peu de développement par toi même
avant de m'y remettre.À bientôt
Re merci d'avoir donné de ton tempsRe, re
Je suis toujours réticent pour modifier les macros d'autant plus que pour tes formules de calcul je peux te proposer plus simple (formules matricielle validées par CTRL MAJ Entrée) :
La 1ère semaine s'étendant sur la plage A2:H17
Cumul de la semaine pour le collaborateur 1 ligne 3(les accolades sont mises par Excel lors de la validation.)Enrichi (BBcode):{=SOMME(SI(SIERREUR(TROUVE(" à ";B3:H3;1);0);CNUM(STXT(B3:H3;9;5))-CNUM(STXT(B3:H3;1;5));0))}
Sous total de la première semaine ligne 2Cumul des 6 semaines ligne 1Enrichi (BBcode):=SOUS.TOTAL(9;I3:I17)Enrichi (BBcode):=SOUS.TOTAL(9;I2:I97)
Maintenant si tu ne veux absolument pas de cette solution, je te laisse faire un peu de développement par toi même
À bientôt
je tiens a ma feuille nous en avons l'habitude.
Je vais donc essayer de comprendre d'adapter ta macro pour mon besoins
a bientôt
Bonjour à toutes & à tous, bonjour @chich
Le remplissage du tableau hebdomadaire est fait dans cette partie de la macro :
L'écriture se fait d'un seul coup pour chaque semaine avec la ligne de commande :
Me.[Date_J].Offset(1 + (Sem - 1) * (NbCLB + 1)).Resize(NbCLB).Value = TbHoraires
Biensur avec le doublement du nombre de colonnes et les lignes supplémentaires de présentation,
tu devras ajuster la taille du tableau TbHoraires avant de le reremplir (il est utiliser plus haut dans le code pour lire les horaires type de chaque collaborateur dans la la feuille "Tables".
Et tu devras aussi adapter le passage d'un jour à l'autre (avec un facteur 2) et d'une semaine à l'autre (Nbre de collaborateurs + nombre de lignes de présentation)
Je te laisse chercher un peu pour t'approprier le projet, si tu bloques, je te proposerai une solution.
A bientôt
Le remplissage du tableau hebdomadaire est fait dans cette partie de la macro :
Enrichi (BBcode):
...
'tableau par collaborateur et jour de la semaine
ReDim TbHoraires(1 To NbCLB, 1 To 7)
...
ReDim TbIdxMA(1 To NbCLB, DateDéb To DateFin, 1 To 2)
...
'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
Dim TbTemp(): Taille = 0
'On va placer dans TbHoraires Les absences ou les plages horaire (TbHoraires recouvre 1 semaine)
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)
TbHoraires(CLB, J) = tbABS(CLB, DateJ)
ArrDép = Split(tbABS(CLB, DateJ), " à ")
If InStr(1, tbABS(CLB, DateJ), " à ", vbTextCompare) > 0 Then
ArrDép = Split(tbABS(CLB, DateJ), " à ")
Taille = Taille + 1: ReDim Preserve TbTemp(1 To 6, 1 To Taille)
TbTemp(1, Taille) = CDbl(DateJ): TbTemp(2, Taille) = WorksheetFunction.IsoWeekNum(DateJ): TbTemp(3, Taille) = Collab(CLB, 1): TbTemp(4, Taille) = CDbl(CDate(ArrDép(0))): TbTemp(5, Taille) = CDbl(CDate(ArrDép(1))): TbTemp(6, Taille) = TbTemp(5, Taille) - TbTemp(4, Taille)
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
'On applique les couleurs
With Me.[Date_J].Offset(1 + (Sem - 1) * (NbCLB + 1) + CLB - 1, J - 1).Resize(1, 1)
.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é
Me.[Date_J].Offset(1 + (Sem - 1) * (NbCLB + 1)).Resize(NbCLB).Value = TbHoraires
Next Sem
...- Le tableau TbHoraires(CLB, J) correspond à la taille d'une semaine (nbre de collaborateurs= ligne, nbre de jours = 7).
- Le tableau TbIdxMA(CLB, DateJ, 1 ou 2) contient les couleurs associées aux motifs d'absences (3 dimensions : CLB Collaborateurs ; date ; 1 couleur de fond et 2 couleur de police).
- Le tableau tbABS(CLB, DateJ) contient pour chaque collaborateur et pour chaque jour l'information à écrire (horaire sous la forme hh:mm à hh:mm, Repos H , Férié ou motif d'absence).
- Me.[Date_J] est la première ligne de la 1ère semaine (Nom défini Date_J ='Plng Hebdo'!$B$2:$H$2 dans ma version , .Offset(1 + (Sem - 1) * (NbCLB + 1)) permet d'obtenir la ligne pour la semaine en cours, .Resize(NbCLB).Value redimensionne le nombre de ligne de cette plageau nombre de collaborateurs.
L'écriture se fait d'un seul coup pour chaque semaine avec la ligne de commande :
Me.[Date_J].Offset(1 + (Sem - 1) * (NbCLB + 1)).Resize(NbCLB).Value = TbHoraires
Biensur avec le doublement du nombre de colonnes et les lignes supplémentaires de présentation,
tu devras ajuster la taille du tableau TbHoraires avant de le reremplir (il est utiliser plus haut dans le code pour lire les horaires type de chaque collaborateur dans la la feuille "Tables".
Et tu devras aussi adapter le passage d'un jour à l'autre (avec un facteur 2) et d'une semaine à l'autre (Nbre de collaborateurs + nombre de lignes de présentation)
Je te laisse chercher un peu pour t'approprier le projet, si tu bloques, je te proposerai une solution.
A bientôt
Dernière édition:
Bonjour a vous tous
AtTheOne
Merci pour ton retour
je viens de faire un test mais je ne sais ou vas cette partie?
VB:
If InStr(1, tbABS(CLB, DateJ), " à ", vbTextCompare) > 0 Then
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
TbHoraires(CLB, 1 + (J - 1) * 2) = tbABS(CLB, DateJ)
TbHoraires(CLB, 2 + (J - 1) * 2) = Empty
End If
VB:
ReDim TbHoraires(1 To NbCLB, 1 To 14)Re
Mon post #51 a évolué, je m'étais absenté en cours de rédaction ...
Il faut prévoir une macro de réinitialisation des 6 planning hebdo (vidés des valeurs précédentes, cellules non fusionnées, couleurs fond et police)
La partie que tu cites devrait s'inclure dans cette partie du code :
la partie :
Le code barré en noir doit être supprimé (tu n'utilises pas la feuille BdD)
Le code en vert Gras doit être ajouté à cet endroit car TbHoraires est utilisé plus haut dans le code pour stocker les horaires type des collaborateurs (avec seult 7 colonnes)
Le code en vert non gras doit être adapté en fonction des dimensions du planning d'une semaine (en tenant compte des lignes de présentation, en fusionnant les cellules qui contiennent un motif d'absence, férié etc.
Je te laisse un peu chercher puis je t'envoie une solution, je pense que c'est la meilleur façon pour que tu t'appropries ces macros.
A bientôt
Mon post #51 a évolué, je m'étais absenté en cours de rédaction ...
Il faut prévoir une macro de réinitialisation des 6 planning hebdo (vidés des valeurs précédentes, cellules non fusionnées, couleurs fond et police)
La partie que tu cites devrait s'inclure dans cette partie du code :
Enrichi (BBcode):
...
Redim TbHoraire(1 to NbCLB, 1 to 14) Dim TbTemp(): Taille = 0
'On va placer dans TbHoraires les absences ou les plages horaire (TbHoraires recouvre 1 semaine)
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)
TbHoraires(CLB, J) = tbABS(CLB, DateJ)
ArrDép = Split(tbABS(CLB, DateJ), " à ")
If InStr(1, tbABS(CLB, DateJ), " à ", vbTextCompare) > O Then
ArrDép = Split(tbABS(CLB, DateJ), " à ")
Taille = Taille + 1: ReDim Preserve TbTemp(1 To 6, 1 To Taille)
TbTemp(1, Taille) = CDbl(DateJ): TbTemp(2, Taille) = WorksheetFunction.IsoWeekNum(DateJ): TbTemp(3, Taille) = Collab(CLB, 1): TbTemp(4, Taille) = CDbl(CDate(ArrDép(0))): TbTemp(5, Taille) = CDbl(CDate(ArrDép(1))): TbTemp(6, Taille) = TbTemp(5, Taille) - TbTemp(4, Taille)
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
'On applique les couleurs
With Me.[Date_J].Offset(1 + (Sem - 1) * (NbCLB + 1) + CLB - 1, J - 1).Resize(1, 1)
.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é
Me.[Date_J].Offset(1 + (Sem - 1) * (NbCLB + 1)).Resize(NbCLB).Value = TbHoraires
Next Sem
With BdD.[Tb_BdD]
.ClearContents
.ListObject.Resize BdD.[Tb_BdD].Offset(-1).Resize(1 + Taille)
.Value = WorksheetFunction.Transpose(TbTemp)
With .ListObject.Sort
.SortFields.Clear
.SortFields.Add Key:=BdD.[Tb_BdD[Collaborateur]], SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=BdD.[Tb_BdD[Date]], SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
End Withla partie :
Enrichi (BBcode):
If InStr(1, tbABS(CLB, DateJ), " à ", vbTextCompare) > 0 Then
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)))ElseTbHoraires(CLB, 1 + (J - 1) * 2) = tbABS(CLB, DateJ)TbHoraires(CLB, 2 + (J - 1) * 2) = EmptyEnd If
devrait apparaître à la place du code barré en rougeLe code barré en noir doit être supprimé (tu n'utilises pas la feuille BdD)
Le code en vert Gras doit être ajouté à cet endroit car TbHoraires est utilisé plus haut dans le code pour stocker les horaires type des collaborateurs (avec seult 7 colonnes)
Le code en vert non gras doit être adapté en fonction des dimensions du planning d'une semaine (en tenant compte des lignes de présentation, en fusionnant les cellules qui contiennent un motif d'absence, férié etc.
Je te laisse un peu chercher puis je t'envoie une solution, je pense que c'est la meilleur façon pour que tu t'appropries ces macros.
A bientôt
Dernière édition:
ok merci beaucoup je regarde et je reviens vers toi.
Bonjour à toutes et à tous, bonjour @chich
J'ai profité de ces 2 jours pour faire l'adaptation.
J'ai mis les 2 macros dans un module à part "Actions_Plgn_Hebdo" en laissant la mise à jour des dates et des N° de semaine dans "Worksheet_Change" (pas très cohérent tout ça mais ...)
J'ai commenté un max ...
Code pour la remise à zéro des planning :
Code pour la mise à jour des horaires et absences
Code de la feuille
Voir le fichier joint
A bientôt
J'ai profité de ces 2 jours pour faire l'adaptation.
J'ai mis les 2 macros dans un module à part "Actions_Plgn_Hebdo" en laissant la mise à jour des dates et des N° de semaine dans "Worksheet_Change" (pas très cohérent tout ça mais ...)
J'ai commenté un max ...
Code pour la remise à zéro des planning :
VB:
'========================================
'Remise à zéro des plannings hebdomadaire
'========================================
Sub RàZ_SemPlgnHebdo()
'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
'Nombre de collaborateurs
NbCLB = Tables.[tb_Collaborateurs].Rows.Count
'RàZ des cellules de chaque planning hebdo
'RàZ des dates et des horaires des NbSemH semaines (le contenu)
For i = 0 To NbSemH - 1
Plgn_Hebdo.[Date_J].Offset(1).Resize(NbCLB + 3).Offset(i * (NbCLB + 4)).ClearContents
Next
'RàZ des Horaires ou motifs d'absence de la 1ère semaine (les formats)
With Plgn_Hebdo.[Date_J].Offset(3).Resize(NbCLB, 2)
.UnMerge
.Interior.Color = 16777215
.Font.Color = -65536
With .Borders(xlInsideVertical)
.Weight = xlHairline
End With
.Copy
Plgn_Hebdo.[Date_J].Offset(3).Resize(NbCLB).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With
'Recopie des formats sur les autres semaines
Plgn_Hebdo.[Date_J].Resize(NbCLB + 4).Copy
For i = 1 To NbSemH - 1
Plgn_Hebdo.[Date_J].Resize(NbCLB + 4).Offset((NbCLB + 4) * i).PasteSpecial Paste:=xlPasteFormats
Next
'Rétablir les états initiaux
With Application
.CutCopyMode = False
.EnableEvents = EtatEvénements
.ScreenUpdating = EtatScreen
.Calculation = EtatCalcul
End With
End SubCode pour la mise à jour des horaires et absences
VB:
'=========================================================================================
'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 SubCode de la feuille
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TbDates(1 To NbSemH, 1 To 14) 'Date en valeurs (toutes les 2 cellules d'où 14)
Collab = Tables.[tb_Collaborateurs].Columns(1).Value: NbCLB = UBound(Collab, 1) 'Nb de collaborateurs
NbMA = Tables.[tb_Type_Arrêt].Rows.Count 'Nb de motif d'absence
Mois = Me.[Mois_H].Value 'Mois sélectionné pour les planning hebdo
Année = Me.[Année_H].Value 'Année sélectionnée pour les planning hebdo
'Redéfinir les noms dépendant du Nbr Arrêts et du Nbr Collaborateurs
With ThisWorkbook.Names
.Add "Planning_Collaborateurs", Me.[Planning_ComptageAbsences].Offset(1).Resize(NbCLB)
.Add "ZoneSaisie", Me.[Planning_Collaborateurs].Offset(NbCLB).Resize((NbMA + 1) * NbGpL * NbCLB, NbGpC * 5)
End With
'Pas d'action si la(les) cellules modifiée ne concerne(nt) ni l'année ni le mois choisis
If Not (Target.Address = Me.[Année_H].Address Or Target.Address = Me.[Mois_H].Address) Then Exit Sub
'Geler calculs, gestion des évènements, mise à jour de l'affichage
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Remise à zéro des plannings hebdomadaires
RàZ_SemPlgnHebdo
'Mise à jour des dates et des numéros de semaine
'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)")
'Numéro de la ligne contenat le N° de la 1ère semaine
LigneS = Me.[Semaine_1].Cells(1).Row
For Sem = 1 To NbSemH 'Boucle sur les semaines du planning
For J = 1 To 7 'Boucle sur les jours de la semaine
'Date du jour (décaler¨% DateDéb de "Plus" jours
Plus = (Sem - 1) * 7 + J - 1: DateJ = DateDéb + Plus 'Décalage de la date % à la date initiale
TbDates(Sem, 1 + (J - 1) * 2) = CLng(DateJ) 'Dates en valeur dans le tableau
Next
'N° ISO de la semaine
Me.Cells(LigneS + (Sem - 1) * (NbCLB + 4), 1).Value = WorksheetFunction.IsoWeekNum(TbDates(Sem, 1))
'Coller les dates de la semaine
Me.[Date_J].Offset(1 + (Sem - 1) * (NbCLB + 4), 0).Value = WorksheetFunction.Index(TbDates, Sem, 0)
Next
'Lire et écrire les absences enregistrées dans la feuille Planning
LireAbsencesH
'Réactiver calculs, gestion des évènements, mise à jour de l'affichage
With Application
.Goto Target
.Calculation = xlCalculationAutomatic
Me.Calculate
.EnableEvents = True
.ScreenUpdating = True
End With
ActiveWindow.ScrollRow = Me.[Date_J].Row - 1
End SubVoir le fichier joint
A bientôt
Solution
Bonjour a vous tous @AtTheOne
Je te très reconnaissant et te remercie grandement parfait c'est exactement ce que je souhaite.
Bonjour @chich
Merci pour le retour
Au plaisir de te rencontrer sur un autre fil
Merci pour le retour
dans ce cas, peux-tu marquer le post #56 comme solution à ton problème (voir ma signature)
Au plaisir de te rencontrer sur un autre fil
Discussions similaires
- Question
- Résolu(e)
Microsoft 365
Conserver lien hypertexte avec une fonction RechercheV
