XL 2010 Changer la couleur de fond en fonction de la valeur

[ascal44]

Bonjour , j'ai trouvé un code pour changer la couleur de fond en fonction de la valeur à partir de cellules de référence.
Mon tableau est disposé différement et je souhaiterais pour l'appliquer sur le classeur en pièce jointe.
Je vous remercie par avance pour votre aide
Cordialement

 

[sylvanu]

Bonjour Ascal,
Pourquoi ne pas utiliser des MFC, ce serait plus simple.

 

[laurent950]

Bonjour,

Private Sub Worksheet_Change(ByVal Target As Range)
Dim SupRgn As Range
    Set SupRgn = Union(Range("A26:B27"), Range("E26:F27"))
        If Not Intersect(Range("C2:E20"), Target) Is Nothing Then
            For Each rgArea In SupRgn
                If Target.Value = rgArea.Value Then
                    With Target.Interior
                        .Pattern = rgArea.Offset(, 1).Interior.Pattern
                        .PatternColorIndex = rgArea.Offset(, 1).Interior.PatternColorIndex
                        .Color = rgArea.Offset(, 1).Interior.Color
                        .TintAndShade = rgArea.Offset(, 1).Interior.TintAndShade
                        .PatternTintAndShade = rgArea.Offset(, 1).Interior.PatternTintAndShade
                    End With
                    Exit For
                End If
            Next rgArea
        End If
End Sub

 

[mapomme]

Bonsoir @ascal44 , @sylvanu , @laurent950 ,

Mais serait il possible de l’insérer à la suite d'une macro dans un module ?

Une procédure CouleurFond(...) de mon cru (avec paramètres) et un exemple de son utilisation à partir d'une autre macro (macro TEST). Les codes sont un peu commentés. Exécuter la procédure Test qui elle-même lance une procédure CouleurFond(...) avec les bons arguments.

Les codes sont dans module1. Code de la procédure CouleurFond(...) :

'Macro pour colorer le fond des cellules suivant valeurs
Sub CouleurFond(xPlage, ParamArray RefCoul())
   ' xplage    => la plage dont on doit colorer le fond sous conditions
   ' RefCoul   => les différentes plages contenant les mots-clefs
Dim dico, x, y, old
   old = Application.ScreenUpdating: Application.ScreenUpdating = False    'on bloque l'affichage
   Set dico = CreateObject("scripting.dictionary")    'dictionaire des termes à rechercher avec leur couleur de fond
   xPlage.Interior.ColorIndex = xlColorIndexNone      'le fond de la plage à colorer est mis à aucun remplissage
   For Each x In RefCoul      'pour chaque zone de mots-clefs
      For Each y In x         'pour chaque cellule de mots-clefs de la zone x en cours d'examen
         'si la cellule y est non vide, on ajoute au dico le texte de la cellule associé avec sa couleur de fond
         If Len(y) > 0 Then dico(CStr(y)) = y.Offset(, 1).Interior.Color
      Next y
   Next x
  
   For Each x In xPlage       'pour chaque cellule x de la plage à colorer
      'si le texte de la cellule est non vide et s'il est dans dico alors on applique la couleur de fond
      If x <> "" Then If dico.exists(CStr(x)) Then x.Interior.Color = dico(CStr(x))
   Next x
   Application.ScreenUpdating = old    'on remet l'affichage à son statut avant la macro
End Sub

 

[Staple1600]

Bonsoir @mapomme

Juste pour info

Sub Taquinerie_A()
'ici selection = TCD
CouleurFond Selection, Selection
End Sub
Sub Taquinerie_B()
'ici selection = Shape
CouleurFond Selection, Selection
End Sub

PS: La seconde macro a figé mon Excel.
Bizarre, non ?

EDITION: Bizarrement la selection (Shape) est quand même mise en blanc même si VBE bronche.
Par contre ne bronche pas avec un ActiveX.

 

[mapomme]

Bonsoir @Staple1600,

Sub Taquinerie_B()
'ici selection = Shape
CouleurFond Selection, Selection
End Sub

PS: La seconde macro a figé mon Excel.
Bizarre, non ?

Mais c'est d'un machiavélisme le plus fourbe, le plus déloyal, le plus traître, le plus sournois, le plus pervers, le plus retors que je n'ai jamais côtoyé. Je ne vous félicite pas Monsieur pas franc du collier.
Vous avez gâché ma soirée et me voila obligé de noyer mon dépit dans les boissons alcoolisées pour oublier la méchanceté de certaines personnes que je désignerai pas n'étant pas un délateur comme d'aucun. Vous avez été plus efficace qu'une balle de fusil, vous m'avez abattu, je suis anéanti. M'en remettrai-je ?

 

[Staple1600]

Monsieur @mapomme

Le like déposé à votre endroit dans le message#5 est le pansement pour la taquinerie bon enfant du message#6

Subséquemment, je ne saurai être tenu responsable de vos libations éthyliques.

Ma blagounette n'était qu'un hommage déguisé à votre prose VBAistique.

Et une invitation à ajouter le bout de code pour éviter la loi de Murphy et l'ICC(*)
(*) dont j'ai revêtu la panoplie un court instant.

Vous sachant en plein possession de vos moyens Excelliens, veuillez agréer, Monsieur, l'option explicite, de mes procédures les plus distinguées.

 

[mapomme]

Re,
Ma colère et ma crise de nerf s'étant quelque peu estompées, on pourra déjouer la félonie de certains (dont M. Fermail 0,000000001600 fait assurément partie) avec ces quelques instructions insérées après la ligne Dim de la procédure:

   ' Début de la verrue dite "Verrue de staple1600"
   If TypeName(xPlage) <> "Range" Then Exit Sub
   For Each x In RefCoul
      If TypeName(x) <> "Range" Then Exit Sub
   Next x
   ' Fin de la verrue dite "Verrue de staple1600"

 

[mapomme]

la verrue (c'est pas gentil)

C'est le terme consacré pourtant pour un programme informatique. Ce n'est ni gentil ni méchant.

Quant à la chanson, je sèche. Sheldon.

 

[Staple1600]

@mapomme
KADO
Bouge ton corps

 

[Staple1600]

@mapomme
Une question
Pourquoi tu passes par un Offset ?
Tu pourrais prendre la couleur de la cellule où est le mot ?

[aparté]
NB: Cet aparté sera supprimé avant minuit.
L'aparté a été supprimé à 23h56
Promesse tenue

[/aparté]