Microsoft 365 Colorier une cellule en fonction de critère d'un autre onglet

Roseline · 6 Décembre 2022

Bonjour le forum,

J'ai besoin de votre aide concernant mon fichier. J'ai tenté avec une mise en forme conditionnelle mais j'ai rien trouvé et encore moins en vba.
Je vous explique ma situation.

J'ai deux onglets. Le premier "Horaire" est mon horaire du lundi au vendredi
Mon deuxième onglet c'est la cédule de mes personnes par journée. Les noms inscrits à cet endroit changeront toutes les semaines.

Ce que je n'arrive pas à faire c'est ceci
Si j'inscrit le nom d'une personne dans une journée dans mon onglet "Horaire" et que le nom de cette personne se retrouve dans la même journée dans mon onglet "Cédule", j'ai besoin que son nom devienne bleu. Tout comme mon exemple. Rose est indiquée dans lundi dans mon onglet "Cédule" et je l'ai ajouté dans mon onglet "Horaire" le lundi donc elle est devenue bleu. Par contre, pour le mardi elle n'a pas changé ni pour le mercredi.

Merci de votre aide et bonne journée

sylvanu · 6 Décembre 2022

Bonsoir Roseline, Job,
Une autre approche, se colore en temps réel quand on saisie des prénoms dans les cellules, avec :

VB:

Sub Worksheet_Change(ByVal Target As Range)
Dim Liste, Jour$, Colonne%, N%, Début%, Longueur%
On Error GoTo Fin: If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [C2:G11]) Is Nothing Then                  ' Si clic dans ce tableau
         Application.ScreenUpdating = False                             ' On fige l'écran
         Cells(Target.Row, Target.Column).Font.Color = vbBlack          ' Couleur par défaut
         Cells(Target.Row, Target.Column).Font.Bold = False
         Liste = Split(Target, Chr(10))                                 ' Liste des prénoms présent dans la cellule
         If...

job75 · 6 Décembre 2022

Bonsoir Roseline,

Voyez le fichier joint et cette macro dans le code de la feuille "Horaire" :

VB:

Private Sub Worksheet_Activate()
Dim c As Range, x$, jour$, L%, cc As Range, y$, i%
Application.ScreenUpdating = False
With [C2:G11]
    .Font.ColorIndex = xlAutomatic 'RAZ
    For Each c In Sheets("Cédule").[A1].CurrentRegion.Offset(1)
        If c <> "" Then
            x = c
            jour = c(2 - c.Row)
            L = Len(x)
            For Each cc In .Cells
                y = cc
                For i = 1 To L
                    If Mid(y, i, L) = x Then If cc(1, 2 - cc.Column).MergeArea(1) = jour _
                        Then cc.Characters(i, L).Font.Color = vbRed: Exit For
            Next i, cc
        End If
    Next c
End With
End Sub

Elle se déclenche quand on active la feuille.

Le rouge est plus visible que le bleu.

A+

sylvanu · 6 Décembre 2022

Bonsoir Roseline, Job,
Une autre approche, se colore en temps réel quand on saisie des prénoms dans les cellules, avec :

VB:

Sub Worksheet_Change(ByVal Target As Range)
Dim Liste, Jour$, Colonne%, N%, Début%, Longueur%
On Error GoTo Fin: If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [C2:G11]) Is Nothing Then                  ' Si clic dans ce tableau
         Application.ScreenUpdating = False                             ' On fige l'écran
         Cells(Target.Row, Target.Column).Font.Color = vbBlack          ' Couleur par défaut
         Cells(Target.Row, Target.Column).Font.Bold = False
         Liste = Split(Target, Chr(10))                                 ' Liste des prénoms présent dans la cellule
         If Target.Row Mod 2 = 0 Then Jour = Cells(Target.Row, "A") _
         Else Jour = Cells(Target.Row - 1, "A")                         ' Recherche du jour correspondant
         Colonne = Application.Match(Jour, Sheets("Cédule").[1:1], 0)   ' Quelle colonne correspond à ce jour ?
         For N = 0 To UBound(Liste)                                     ' Pour tous les prénoms
            Prénom = Liste(N)                                           ' Extraction du prénom à analyser
            L = 2                                                       ' Première ligne d'analyse
            While Sheets("Cédule").Cells(L, Colonne) <> ""              ' Tant que la liste n'est pas finie
                If Sheets("Cédule").Cells(L, Colonne) = Prénom Then     ' Si le Prénom est présent dans cette liste
                    Début = Application.Search(Prénom, Target)          ' Chercher début prénom dans la cellule
                    Longueur = Len(Prénom)                              ' et longueur du prénom
                    With Cells(Target.Row, Target.Column). _
                        Characters(Start:=Début, Length:=Longueur).Font ' Pour ce mot dans la cellule
                        .FontStyle = "Gras"                             ' Mettre en gras
                        .Color = RGB(0, 180, 240)                       ' Bleu
                    End With
                End If
                L = L + 1                                               ' Prochain prénom
            Wend
        Next N
    End If
Fin:
End Sub

Roseline · 7 Décembre 2022

sylvanu à dit:

Bonsoir Roseline, Job,
Une autre approche, se colore en temps réel quand on saisie des prénoms dans les cellules, avec :

VB:

Sub Worksheet_Change(ByVal Target As Range)
Dim Liste, Jour$, Colonne%, N%, Début%, Longueur%
On Error GoTo Fin: If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [C2:G11]) Is Nothing Then                  ' Si clic dans ce tableau
         Application.ScreenUpdating = False                             ' On fige l'écran
         Cells(Target.Row, Target.Column).Font.Color = vbBlack          ' Couleur par défaut
         Cells(Target.Row, Target.Column).Font.Bold = False
         Liste = Split(Target, Chr(10))                                 ' Liste des prénoms présent dans la cellule
         If Target.Row Mod 2 = 0 Then Jour = Cells(Target.Row, "A") _
         Else Jour = Cells(Target.Row - 1, "A")                         ' Recherche du jour correspondant
         Colonne = Application.Match(Jour, Sheets("Cédule").[1:1], 0)   ' Quelle colonne correspond à ce jour ?
         For N = 0 To UBound(Liste)                                     ' Pour tous les prénoms
            Prénom = Liste(N)                                           ' Extraction du prénom à analyser
            L = 2                                                       ' Première ligne d'analyse
            While Sheets("Cédule").Cells(L, Colonne) <> ""              ' Tant que la liste n'est pas finie
                If Sheets("Cédule").Cells(L, Colonne) = Prénom Then     ' Si le Prénom est présent dans cette liste
                    Début = Application.Search(Prénom, Target)          ' Chercher début prénom dans la cellule
                    Longueur = Len(Prénom)                              ' et longueur du prénom
                    With Cells(Target.Row, Target.Column). _
                        Characters(Start:=Début, Length:=Longueur).Font ' Pour ce mot dans la cellule
                        .FontStyle = "Gras"                             ' Mettre en gras
                        .Color = RGB(0, 180, 240)                       ' Bleu
                    End With
                End If
                L = L + 1                                               ' Prochain prénom
            Wend
        Next N
    End If
Fin:
End Sub

Merci beaucoup c'est exactement ce qu'il me fallait. J'ai ajusté le tout à mon fichier original et ça fonctionne parfaitement bien et en temps réel. Vous m'avez sauvé beaucoup de travail et je vous en remercie grandement.
Bonne journée à vous Sylvanu

Roseline · 7 Décembre 2022

job75 à dit:

Bonsoir Roseline,

Voyez le fichier joint et cette macro dans le code de la feuille "Horaire" :

VB:

Private Sub Worksheet_Activate()
Dim c As Range, x$, jour$, L%, cc As Range, y$, i%
Application.ScreenUpdating = False
With [C2:G11]
    .Font.ColorIndex = xlAutomatic 'RAZ
    For Each c In Sheets("Cédule").[A1].CurrentRegion.Offset(1)
        If c <> "" Then
            x = c
            jour = c(2 - c.Row)
            L = Len(x)
            For Each cc In .Cells
                y = cc
                For i = 1 To L
                    If Mid(y, i, L) = x Then If cc(1, 2 - cc.Column).MergeArea(1) = jour _
                        Then cc.Characters(i, L).Font.Color = vbRed: Exit For
            Next i, cc
        End If
    Next c
End With
End Sub

Elle se déclenche quand on active la feuille.

Le rouge est plus visible que le bleu.

A+

Bonjour job75,
Merci beaucoup pour votre aide dans ce dossier.
Bonne journée à vous job75

sylvanu · 7 Décembre 2022

Bonsoir,
Cependant je me suis aperçu d'un petit "bug".
Si vous changé la liste en Cédule ( évolutions, fautes d'orthographe ... ) la page Horaire ne sera pas modifiée, ce qui est un peu ballot.
Donc dans cette PJ j'ai repris la même macro, plus une seconde qui remet tout à jour quand on sélectionne la feuille, un peu la même approche que Job.
Donc si vous modifier la liste Cédule, Horaire sera remis automatiquement à jour dès que vous sélectionnerez cette feuille, tout en conservant l'aspect temps réel sur la feuille Horaire.

patricktoulon · 7 Décembre 2022

bonsoir sylvanu
juste en passant je me suis permis de simplifier la chose
et d'ajouter le défaut de casse
on peut donc taper les nom en minuscule

VB:

Sub Analyse(ByVal Target As Range)
Dim x&
'on récupère la liste de nom(colonne correspondant  à la ligne jour
    Liste = Sheets("Cédule").Columns(Target.Row / 2).Resize(Sheets("Cédule").UsedRange.Rows.Count)
    With Target
        .Font.Color = vbBlack
        .Font.Bold = False
        Application.EnableEvents = False
        Target = StrConv(Target, vbProperCase)
        For i = 1 To UBound(Liste)
            x = InStr(1, Target.Text, Liste(i, 1), vbTextCompare)
            If x > 0 Then
                With .Characters(Start:=x, Length:=Len(Liste(i, 1))).Font
                    .Color = vbCyan
                    .Bold = True
                End With
            End If
        Next
    End With
    Application.EnableEvents = True
End Sub

Microsoft 365 Colorier une cellule en fonction de critère d'un autre onglet

Roseline

XLDnaute Occasionnel

Pièces jointes

sylvanu

job75

XLDnaute Barbatruc

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

Roseline

XLDnaute Occasionnel

Roseline

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Discussions similaires