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

mapomme à dit:

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 :

VB:

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

Cliquez pour agrandir...

Roseline à dit:

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.

Cliquez pour agrandir...

mapomme à dit:

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" :

VB:

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

Cliquez pour agrandir...