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

  • Initiateur de la discussion Initiateur de la discussion Roseline
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Roseline

XLDnaute Occasionnel
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
 

Pièces jointes

Solution
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...
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
 

Pièces jointes

Dernière édition:
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
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
 
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
 

Pièces jointes

Dernière édition:
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
Bonjour,
C'est en plein ce que je voulais. Je l'ai adapté à mon fichier et tout fonctionne à merveille. Merci beaucoup de ton aide.
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
2
Affichages
462
Retour