XL 2016 Couleurs d'objets / valeurs

Hopson

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

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

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

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

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

XLDnaute Nouveau
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é
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 909
Membres
101 836
dernier inscrit
karmon