Microsoft 365 Colorier une cellule selon plusieurs critères en VBA

[Roseline]

Bonjour,
Je connais les MFC mais j'aimerais mieux avec cela sous forme de VBA qui se déclenche automatiquement si c'est possible.
J'ai un tableau dans lequel j'aimerais que dès qu'un tel cellule comporte tel mot, elle devienne de telle couleur et ainsi de suite.
J'aimerais aussi que dès que l'information est changé dans une cellule que l'ajustement de couleur se fasse aussi automatiquement.
J'ai mis un exemple en guise de référence.
Merci de votre aide

 

[mapomme]

Bonjour @Roseline 🙂,

Un essai. Le code est dans le module de la feuille ayant onglet "Feuil1".
Le tableau de référence pour les couleurs a été converti en tableau structuré (tRefCoul).
Le tableau source est le tableau "Tbase".

Le code :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xrg As Range, x, n&
   With Worksheets("Feuil1")
      On Error Resume Next
      Set xrg = Intersect(Worksheets("Feuil1").ListObjects("Tbase").DataBodyRange, Target)
      On Error GoTo 0
      If xrg Is Nothing Then Exit Sub
      For Each x In xrg
         n = Application.IfError(Application.Match(x.Value, Worksheets("Feuil1").ListObjects("tRefCoul").DataBodyRange, 0), 0)
         If n = 0 Then
            x.Font.ColorIndex = xlColorIndexAutomatic
         Else
            x.Font.Color = .ListObjects("tRefCoul").DataBodyRange(n).Font.Color
         End If
      Next x
   End With
End Sub

 

[Roseline]

Bonjour @Roseline 🙂,

Un essai. Le code est dans le module de la feuille ayant onglet "Feuil1".
Le tableau de référence pour les couleurs a été converti en tableau structuré (tRefCoul).
Le tableau source est le tableau "Tbase".

Le code :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xrg As Range, x, n&
   With Worksheets("Feuil1")
      On Error Resume Next
      Set xrg = Intersect(Worksheets("Feuil1").ListObjects("Tbase").DataBodyRange, Target)
      On Error GoTo 0
      If xrg Is Nothing Then Exit Sub
      For Each x In xrg
         n = Application.IfError(Application.Match(x.Value, Worksheets("Feuil1").ListObjects("tRefCoul").DataBodyRange, 0), 0)
         If n = 0 Then
            x.Font.ColorIndex = xlColorIndexAutomatic
         Else
            x.Font.Color = .ListObjects("tRefCoul").DataBodyRange(n).Font.Color
         End If
      Next x
   End With
End Sub

Bonjour,
J'adore le tableau présenté mais j'ai de la difficulté à l'appliquer dans mon fichier. Le tableau de référence pour les couleurs est sur un autre onglet dès que je transfert le tableau des couleurs sur cet onglet, la vba ne fonctionne plus.
Merci

 

[mapomme]

e tableau de référence pour les couleurs est sur un autre onglet dès que je transfert le tableau des couleurs sur cet onglet, la vba ne fonctionne plus.

Bonjour @Roseline 🙂,
Bon je fais un exemple avec le tableau des couleurs sur autre feuille. Attendre un peu , svp.

 

[mapomme]

Re,

Voici la version v2.

• La feuille du tableau source (à colorer) s'appelle "Source"
• Le tableau source débute en cellule A1
• La feuille du tableau des références de couleur s'appelle "Data"
• Le tableau des couleurs débute en cellule C1

Le code est un peu commenté. Le code est dans le module associé à la feuille "Source" :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xrg As Range, x, n&
Dim ts1 As ListObject, ts2 As ListObject
      Set ts1 = Worksheets("Source").Range("a1").ListObject       ' Tableau source situé en cellule A1 de la feuille "Source"
      Set ts2 = Worksheets("Data").Range("c1").ListObject         ' Tableau des couleurs situé en cellule C1 de la feuille "Data"
      On Error Resume Next                                        ' au cas où l'intersection serait vide
      Set xrg = Intersect(ts1.DataBodyRange, Target)              ' intersection de la plage du tableau source et des cellules modifiées
      On Error GoTo 0                                             ' on intercepte à nouveau les erreurs
      If xrg Is Nothing Then Exit Sub                             ' si l'intersection est vide, on quitte la procédure
      For Each x In xrg                                           ' Pour chaque cellule de l'intersection
         ' on recherche le rang du texte dans le tableau des couleurs (avec application.Match - correspond à un EQUIV() dans Excel)
         ' si le texte n'y est pas, on renvoie 0                      (avec application.IfError - correspond à un SIERREUR() dans Excel)
         n = Application.IfError(Application.Match(x.Value, ts2.DataBodyRange, 0), 0)
         If n = 0 Then
            ' n = 0 => le texte est de la couleur par défaut du texte
            x.Font.ColorIndex = xlColorIndexAutomatic
         Else
            ' n <> 0 => la couleur du texte est celle de la cellule du texte dans le tableau des couleurs
            x.Font.Color = ts2.DataBodyRange(n).Font.Color
         End If
      Next x

 

[Roseline]

Re,

Voici la version v2.

• La feuille du tableau source (à colorer) s'appelle "Source"
• Le tableau source débute en cellule A1
• La feuille du tableau des références de couleur s'appelle "Data"
• Le tableau des couleurs débute en cellule C1

Le code est un peu commenté. Le code est dans le module associé à la feuille "Source" :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xrg As Range, x, n&
Dim ts1 As ListObject, ts2 As ListObject
      Set ts1 = Worksheets("Source").Range("a1").ListObject       ' Tableau source situé en cellule A1 de la feuille "Source"
      Set ts2 = Worksheets("Data").Range("c1").ListObject         ' Tableau des couleurs situé en cellule C1 de la feuille "Data"
      On Error Resume Next                                        ' au cas où l'intersection serait vide
      Set xrg = Intersect(ts1.DataBodyRange, Target)              ' intersection de la plage du tableau source et des cellules modifiées
      On Error GoTo 0                                             ' on intercepte à nouveau les erreurs
      If xrg Is Nothing Then Exit Sub                             ' si l'intersection est vide, on quitte la procédure
      For Each x In xrg                                           ' Pour chaque cellule de l'intersection
         ' on recherche le rang du texte dans le tableau des couleurs (avec application.Match - correspond à un EQUIV() dans Excel)
         ' si le texte n'y est pas, on renvoie 0                      (avec application.IfError - correspond à un SIERREUR() dans Excel)
         n = Application.IfError(Application.Match(x.Value, ts2.DataBodyRange, 0), 0)
         If n = 0 Then
            ' n = 0 => le texte est de la couleur par défaut du texte
            x.Font.ColorIndex = xlColorIndexAutomatic
         Else
            ' n <> 0 => la couleur du texte est celle de la cellule du texte dans le tableau des couleurs
            x.Font.Color = ts2.DataBodyRange(n).Font.Color
         End If
      Next x

Bonjour,
C'est en plein ce que je voulais. Je l'ai adapté à mon fichier et tout fonctionne à merveille. Merci beaucoup de ton aide.