XL 2016 Couleurs d'objets / valeurs

[Hopson]

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]

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 :

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]

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 :

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]

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 :

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]

C'est quoi le message de bug ?

 

[Hopson]

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]

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

 

[Hopson]

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

Même chose que précédemment

 

[fanch55]

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 :

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]

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 :

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é