XL 2016 Couleurs d'objets / valeurs

Hopson · 23 Novembre 2021

Bonjour à tous,

Je suis à la recherche d'un code VBA pour la fonction suivante :

Couleurs de fond d'un objet en fonction de la valeur Textuel de celui-ci.

Je m'explique :

J'ai une feuille nommé EUROPA qui comporte un tableau nommé BCGT
Dans ce tableau, en colonne H (De H11 à H105 (98lignes)) j'ai 3 types de mention écrit (AM, SEMI-PRO ou PRO)

Chacune de ses mentions de chaque ligne se retrouve également dans des objets sur une nouvelle feuille nommé "Resultats EUROPA"
Un objet = une mention d'une ligne

Je souhaiterais que chaque objet change de couleur en fonction de cette valeur Textuel :
AM = l'objet soit rouge
SEMI-PRO = GRIS
PRO = BLANC

En vous remerciant par avance je n'es aucune idée si cela est possible

fanch55 · 23 Novembre 2021

Bonjour,
en supposant que les objets sont des objets de feuille,
et sans savoir quand ils sont créés ou renseignés:
dans la feuille "Resultats EUROPA", mettre le code ci-dessous :

VB:

Option Compare Text
Private Sub Worksheet_Activate()
    For Each Shp In ActiveSheet.Shapes
        With Shp.OLEFormat.Object
            Select Case .Text
                Case "am":          .Interior.Color = vbRed
                Case "semi-pro":    .Interior.Color = 9868950
                Case "pro":         .Interior.Color = vbWhite
                Case Else:
            End Select
         End With
    Next
End Sub

Hopson · 23 Novembre 2021

fanch55 à dit:
Bonjour,
en supposant que les objets sont des objets de feuille,
et sans savoir quand ils sont créés ou renseignés:
dans la feuille "Resultats EUROPA", mettre le code ci-dessous :

VB:

Option Compare Text Private Sub Worksheet_Activate() For Each Shp In ActiveSheet.Shapes With Shp.OLEFormat.Object Select Case .Text Case "am": .Interior.Color = vbRed Case "semi-pro": .Interior.Color = 9868950 Case "pro": .Interior.Color = vbWhite Case Else: End Select End With Next End Sub

Merci pour votre aide.
Celà n'a pas l'air de fonctionner,

En effet chaque objet a un nom défini (Rectangle1 etc)

Il sont renseignés avec la formule =EUROPA!H1 jusqu'à H105

Peux être que celà peut vous aidera

Hopson · 23 Novembre 2021

fanch55 à dit:
Bonjour,
en supposant que les objets sont des objets de feuille,
et sans savoir quand ils sont créés ou renseignés:
dans la feuille "Resultats EUROPA", mettre le code ci-dessous :

VB:

Option Compare Text Private Sub Worksheet_Activate() For Each Shp In ActiveSheet.Shapes With Shp.OLEFormat.Object Select Case .Text Case "am": .Interior.Color = vbRed Case "semi-pro": .Interior.Color = 9868950 Case "pro": .Interior.Color = vbWhite Case Else: End Select End With Next End Sub

Autant pour moi, il y à un bug débogage. Mais ça met à jour les objets. Et ça fonctionne.

Merci beaucoup cela devait pas me déranger pour le bug.

fanch55 · 23 Novembre 2021

C'est quoi le message de bug ?

Hopson · 23 Novembre 2021

fanch55 à dit:
C'est quoi le message de bug ?

Erreur d'exécution 438
Propriété ou méthode non géré par cet objet

Dans le code il indique en jaune la ligne "SELECT case.text"

Cela se produit quand les mentions change de nom dans un objet suite à un filtre du tableau

fanch55 · 23 Novembre 2021

Si ce sont des rectangles, vous pouvez mette .caption à la place de .text

Hopson · 23 Novembre 2021

fanch55 à dit:
Si ce sont des rectangles, vous pouvez mette .caption à la place de .text

Même chose que précédemment

fanch55 · 23 Novembre 2021

OK, vous devez avoir d'autres objets que des Rectangles et qui n'ont pas la propriété Text ou Caption.
Ce code devrait résoudre le pb :

VB:

Option Compare Text
Private Sub Worksheet_Activate()
    On Error Resume Next
    For Each Shp In ActiveSheet.Shapes
        With Shp.OLEFormat.Object
            Select Case .Text
                Case "am":          .Interior.Color = vbRed
                Case "semi-pro":    .Interior.Color = 9868950
                Case "pro":         .Interior.Color = vbWhite
                Case Else:
            End Select
         End With
    Next
End Sub

Hopson · 23 Novembre 2021

fanch55 à dit:

OK, vous devez avoir d'autres objets que des Rectangles et qui n'ont pas la propriété Text ou Caption.
Ce code devrait résoudre le pb :

VB:

Option Compare Text
Private Sub Worksheet_Activate()
    On Error Resume Next
    For Each Shp In ActiveSheet.Shapes
        With Shp.OLEFormat.Object
            Select Case .Text
                Case "am":          .Interior.Color = vbRed
                Case "semi-pro":    .Interior.Color = 9868950
                Case "pro":         .Interior.Color = vbWhite
                Case Else:
            End Select
         End With
    Next
End Sub

Super ça fonctionne impeccable !
Oui j'avais des rond mais qui n'ont rien à voir présent sur cette feuille.

Un grand merci à vous pour votre aide et la réactivité

XL 2016 Couleurs d'objets / valeurs

Hopson

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

Hopson

XLDnaute Nouveau

Hopson

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

Hopson

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

Hopson

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

Hopson

XLDnaute Nouveau

Discussions similaires