XL 2016 Couleurs d'objets / valeurs

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

Cliquez pour agrandir...

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

Cliquez pour agrandir...

fanch55 à dit:

C'est quoi le message de bug ?

Cliquez pour agrandir...

fanch55 à dit:

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

Cliquez pour agrandir...

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

Cliquez pour agrandir...