Créer une condition
Bonjour,
Pour mon boulot je dois créer un tableau excel.
Nous devons faire des permanences soit de 12h à 13h soit de 13h à 14h soit le soir de 17h30 à 18h.
Nous sommes 3 equipe.
En totalité nous devons effective 12 permanences de 12h à 13h et de 13h à 14h et 9 permanences de 17h30 à 18h.
Ce qui fait 4 personnes par equipe entre 12h et 14h et 3 entre 17h30 et 18h.
Mon probleme est le suivant par colones j'aimerais fixer une limite par equipe où si le nombre de volontaires est deja atteint, ceux qui s'incrivent après soit marquer d'une autre couleur automatiquement afin de pouvoir demander en cas de besoin au personnes inscrit en dernierde ce déplacer.
Vous trouverez un exemple du tableau excel avec les mises en forms conditionnelles.
Merci de votre retour.
Bonjour cece69720,
Je te propose ceci avec du code VBA:
- On modifie l'extension du classeur pour ".xlsm" (pour pouvoir inclure des macros)
- On ajoute une feuille "Paramètres" dans laquelle on stocke les plafonds de 12 et 9 astreintes.
- On définit 4 plages nommées (>Formule>Gestionnaire de noms) pour repérer : la ligne portant les horaires, la ligne portant les totaux, le plafond1 et le plafond2 :
- On ajoute le code suivant dans "Feuil1" :
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const cTextMIDI = "midi"
Const cTextSOIR = "soir"
Dim oCellTotal As Range, oCellHoraire As Range
Dim lRowTotal As Long, lRowHoraires
Dim lRowModif, lColModif
Dim lPlafond As Long, lTotal As Long
'On récupère l'adresse de la ligne d'horaires
Set oCellHoraire = ThisWorkbook.Names("Ligne_Horaires").RefersToRange
lRowHoraires = oCellHoraire.Row
'On récupère l'adresse de la ligne Total
Set oCellTotal = ThisWorkbook.Names("Total_par_créneaux").RefersToRange
lRowTotal = oCellTotal.Row
'On s'assure que la modification porte sur une seule cellule
If Target.Rows.Count = 1 Or Target.Columns.Count = 1 Then
'On s'assure que la cellule modifiée se trouve sur une ligne entre la ligne d'entête et la ligne de total
If Target.Row > lRowHoraires And Target.Row < lRowTotal Then
'On s'assure du texte indiqué dans la cellule modifié
If LCase(Target.Value) = cTextMIDI Or LCase(Target.Value) = cTextSOIR Then
lRowModif = Target.Row
lColModif = Target.Column
'On récupère la cellule d'horaire correspondante
Set oCellHoraire = ActiveSheet.Cells(lRowHoraires, lColModif)
'On récupère le plafond en fonction de l'horaire
If InStr(1, oCellHoraire.Value, "12") > 0 Or InStr(1, oCellHoraire.Value, "13") > 0 Then
lPlafond = ThisWorkbook.Names("Plafond1").RefersToRange.Value
ElseIf InStr(1, oCellHoraire.Value, "17") > 0 Then
lPlafond = ThisWorkbook.Names("Plafond2").RefersToRange.Value
Else
lPlafond = 0
End If
'Si le plafond est affecté on teste le dépassement de plafond
If lPlafond > 0 Then
'On récupère la valeur de la cellule de total correspondante
Set oCellTotal = ActiveSheet.Cells(lRowTotal, lColModif)
lTotal = oCellTotal.Value
'Si le total dépasse le plafond, on met le texte en rouge
If lTotal > lPlafond Then
Target.Font.Color = vbRed
End If
End If
End If
End If
End If
End Sub
Je joins mon classeur de test.
Bonjour,
Je vous remercie pour la réponse.
Je m'excuse je me suis mal exprimé.
La limite que je veux fixer est par équipe et non pas en totalité, c'est à dire que la limite étant de 4 entre 12h et 13h puis 13h et 14h par exemple, lorsque la limite de 4 dans une équipe est atteinte le inscription midi apparaît en une autre couleur.
Cordialement
Cedric
Bonjour Cédric,
En ce cas, je te propose :
-De créer des regroupements de chaque équipe sur la ligne "Manager" correspondant et le code suivant :
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const cTextMIDI = "midi"
Const cTextSOIR = "soir"
Dim oCellTotal As Range, oCellHoraire As Range, oRow As Range
Dim lRowTotal As Long, lRowHoraires
Dim lRowModif, lColModif
Dim lPlafond As Long, lTotal As Long
'On récupère l'adresse de la ligne d'horaires
Set oCellHoraire = ThisWorkbook.Names("Ligne_Horaires").RefersToRange
lRowHoraires = oCellHoraire.Row
'On récupère l'adresse de la ligne Total
Set oCellTotal = ThisWorkbook.Names("Total_par_créneaux").RefersToRange
lRowTotal = oCellTotal.Row
'On s'assure que la modification porte sur une seule cellule
If Target.Rows.Count = 1 And Target.Columns.Count = 1 Then
'On s'assure que la cellule modifiée se trouve sur une ligne entre la ligne d'entête et la ligne de total
If Target.Row > lRowHoraires And Target.Row < lRowTotal Then
'On s'assure du texte indiqué dans la cellule modifié
If LCase(Target.Value) = cTextMIDI Or LCase(Target.Value) = cTextSOIR Then
lRowModif = Target.Row
lColModif = Target.Column
'On récupère la cellule d'horaire correspondante
Set oCellHoraire = ActiveSheet.Cells(lRowHoraires, lColModif)
'On récupère le plafond en fonction de l'horaire
If InStr(1, oCellHoraire.Value, "12") > 0 Or InStr(1, oCellHoraire.Value, "13") > 0 Then
lPlafond = ThisWorkbook.Names("Plafond1").RefersToRange.Value
ElseIf InStr(1, oCellHoraire.Value, "17") > 0 Then
lPlafond = ThisWorkbook.Names("Plafond2").RefersToRange.Value
Else
lPlafond = 0
End If
'Si le plafond est affecté on teste le dépassement de plafond
If lPlafond > 0 Then
'On récupère la valeur de la cellule de total manager correspondante
For Each oRow In ActiveSheet.Range(ActiveSheet.Cells(lRowModif, 1), ActiveSheet.Cells(ActiveSheet.UsedRange.Rows.Count, 1))
If ActiveSheet.Rows(oRow.Row).OutlineLevel = 1 Then
Set oCellTotal = ActiveSheet.Cells(oRow.Row, lColModif)
lTotal = oCellTotal.Value
Exit For
End If
Next
'Si le total dépasse le plafond, on met le texte en rouge
If lTotal > lPlafond Then
Target.Font.Color = vbRed
Else
Target.Font.Color = vbBlack
End If
End If
Else
Target.Font.Color = vbBlack
End If
End If
End If
End Sub
Je joins la nouvelle version de mon classeur de test.
Bonjour,
Je vous remercie ça marche très bien.
Vous savez qu'il y a la possibilité de l'appliquer par zone parce que le nombre de personnes est répartie comme suis :
Lundi et Mardi :
12h à 13h = 4
13h à 14h = 4
17h30 à 18h = 3
Mercredi à Vendredi :
12h à 13h = 3
13h à 14h = 3
17h30 à 18h = 3
Merci de votre retour
Bonsoir Cédric,
Je te propose une 3ème version en P.J.
J'ai transformé la ligne d'entête de jour pour y introduire des dates à la place du texte ce qui permet de tester facilement le jour de la semaine avec le code ajouté suivant :
lRowModif = Target.Row
lColModif = Target.Column
'On récupère la cellule d'horaire correspondante
Set oCellHoraire = ActiveSheet.Cells(lRowHoraires, lColModif)
'On récupère la cellule de date correspondante
Set oCellDate = oCellHoraire.Offset(-1).MergeArea.Cells(1, 1)
iJourSemaine = Weekday(oCellDate.Value, vbMonday) 'On récupère le jour de la semaine
'On fixe le plafond en fonction de l'horaire et du jour de la semaine
If iJourSemaine > 2 Then 'Si le jour de la semaine du mercredi au dimanche -> plafond = 3
lPlafond = ThisWorkbook.Names("Plafond2").RefersToRange.Value
Else
'si l'horaire est entre 12h et 14h -> plafond = 4
If InStr(1, oCellHoraire.Value, "12") > 0 Or InStr(1, oCellHoraire.Value, "13") > 0 Then
lPlafond = ThisWorkbook.Names("Plafond1").RefersToRange.Value
'si l'horaire est 17h30 -> plafond = 3
ElseIf InStr(1, oCellHoraire.Value, "17") > 0 Then
lPlafond = ThisWorkbook.Names("Plafond2").RefersToRange.Value
Else
lPlafond = 0
End If
End If