XL 2016 VBA : Shapes qui ne se colorient pas... (listes déroulantes)

[alain.raphael]

Bonjour,

Mon VBA ne colorient pas mes shapes sélectionnés par mes 6 listes déroulantes... Code dans le module (n°16) . J'ai un "Worksheet_Change" également dans le feuillet.

En fait je souhaiterai colorier les shapes avec les résultats des listes déroulantes mais dès que je remet la liste à son état initial, le shape revienne lui aussi à son état de couleur initiale.

Merci de votre aide

 

[Nicolas JACQUIN]

Bonjour, sans fichier !!!

 

[Nicolas JACQUIN]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim listeZones As Variant
    Dim i As Integer

    ' Liste des cellules contenant les listes déroulantes
    listeZones = Array("B2", "B3", "B4", "B5", "B6", "B7") ' Adapte les adresses si besoin

    For i = LBound(listeZones) To UBound(listeZones)
        If Not Intersect(Target, Me.Range(listeZones(i))) Is Nothing Then
            Call ColorierShapeSelonListe(i + 1, Me.Range(listeZones(i)).Value)
        End If
    Next i
End Sub

Sub ColorierShapeSelonListe(index As Integer, valeur As String)
    Dim shapeNom As String
    Dim couleur As Long

    ' Nom du shape correspondant (Shape1, Shape2, etc.)
    shapeNom = "Shape" & index

    ' Choix de la couleur selon la valeur sélectionnée
    Select Case valeur
        Case "Rouge"
            couleur = RGB(255, 0, 0)
        Case "Vert"
            couleur = RGB(0, 255, 0)
        Case "Bleu"
            couleur = RGB(0, 0, 255)
        Case "Jaune"
            couleur = RGB(255, 255, 0)
        Case "" ' Si la liste est vide, revenir à la couleur initiale (ex : gris clair)
            couleur = RGB(200, 200, 200)
        Case Else
            couleur = RGB(240, 240, 240) ' Couleur par défaut si inconnue
    End Select

    On Error Resume Next
    ActiveSheet.Shapes(shapeNom).Fill.ForeColor.RGB = couleur
    On Error GoTo 0
End Sub

Au hazard, mais sans fichier

 

[alain.raphael]

Nicolas,

J'ai mis le fichier...

 

[job75]

Bonjour à tous,

Voyez le fichier joint et cette macro dans le code de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim s As Shape, c As Range
For Each s In Shapes
    If s.AutoShapeType = msoShapeOval Then
        Set c = Rows("44:45").Find(s.Name, , xlValues, xlPart)
        If c Is Nothing Then s.Fill.ForeColor.RGB = RGB(192, 0, 0) Else s.Fill.ForeColor.RGB = c.DisplayFormat.Interior.Color
    End If
Next
End Sub

Elle colore automatiquement les Shapes "Oval" quand on modifie une cellule des lignes 44 ou 45.

Edit : j'ai remplacé xlWhole par xlPart à cause des espaces superflus.

A+

 

[alain.raphael]

Merci beaucoup : Parfait !!!

 

[job75]

Ma macro précédente colore les Shapes uniquement avec les 2 couleurs de la MFC des lignes 44 et 45.

Il vaut mieux cette macro qui utilise les couleurs des lignes 90 à 115 :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim s As Shape, c As Range
Application.ScreenUpdating = False
For Each s In Shapes
    If s.AutoShapeType = msoShapeOval Then
        s.Fill.ForeColor.RGB = RGB(192, 0, 0) 'RAZ
        Set c = Rows("44:45").Find(s.Name, , xlValues, xlPart) 'xlPart à cause des espaces superflus
        If Not c Is Nothing Then
            Set c = Rows("90:115").Find(c)
            If Not c Is Nothing Then s.Fill.ForeColor.RGB = c(1, 0).Interior.Color
        End If
    End If
Next s
End Sub

 

[job75]

Vous noterez que la recherche par la méthode Find se fait avec xlPart.

C'est à cause des espaces superflus qui terminent les textes en K90 K91 (et K108 qui est un doublon).

 

[alain.raphael]

Rebonjour,

La solution sur l'existant est parfaite. Cependant, est-c que l'on peut cibler 2 listes déroulantes qui elles colorient par exemple en bleu (au lieu du vert pour toutes les autres ?)

 

[job75]

Bonjour,

(au lieu du vert pour toutes les autres ?)

Le vert ? les Shapes utilisent 8 couleurs et aucune n'est verte 🙄

A+

 

[alain.raphael]

Oui parce que je me suis arrêté à la 1ère (fichier Essai)

 

[job75]

Pour rechercher une couleur vous pouvez utiliser cette macro affectée au bouton :

Sub Rechercher_une_couleur()
Dim c As Range, x As Variant, coul&, s As Shape
Application.Goto [C88], True
Application.DisplayAlerts = False
On Error Resume Next
Set c = Application.InputBox("Cliquez sur une cellule colorée :", "Rechercher une couleur", Type:=8)
On Error GoTo 0
If Not c Is Nothing Then
    coul = c(1).Interior.Color
    Application.ScreenUpdating = False
    For Each s In Shapes
       If s.Name Like "*#.#??*" Then
            s.Fill.ForeColor.RGB = RGB(192, 0, 0) 'RAZ
            Set c = Range("F89:K115").Find(s.Name, , xlValues, xlPart)
            If Not c Is Nothing Then If c(1, 0).Interior.Color = coul Then s.Fill.ForeColor.RGB = coul
        End If
    Next
End If
Application.Goto [C43], True
End Sub

Nota 1 : je n'utilise plus le critère s.AutoShapeType car il renvoyait parfois le type msoShapeRectangle au lieu de msoShapeOval !!!

Nota 2 [Edit] : j'ai réussi à renommer la Shape 8.4 "8.4 CS Argeles sur mer Mas Christine", ça à l'air d'aller...