XL 2016 Mise en forme conditionnelle d'une forme (cartographie)

[francois95]

Bonjour, j'ai recherché sur le forum mais je n'ai pas trouvé. Je souhaite pouvoir appliquer une couleur à une forme selon son résultat. Comme une mise en forme conditionnelle d'une cellule mais avec une forme ( cartographie des 8 départements d'Ile de France).

Je vous joint mon fichier en exemple, de B2 à B9 j’ai un nombre par département, et en B4,B15, B16 et D15, les différentes valeurs d’objectif.

Si l'un ou l'une d'entre vous pouvez m'aider, ce serait vraiment top.

Je vous remercie par avance.
François

 

[vgendron]

bonjour

déjà.. il y a plusieurs pb
la fonction : il a du y avoir un couper hasardeux

Function MiseEnCouleur(dept75,range(toto:).displayFormat.Interior.Color, taux)

dans les modules, les code _change doivent être dans le code de la feuille

 

[vgendron]

sinon ce code à mettre dans un module standard

Sub ColorerShapes()
    'on récupère les valeurs de référence
    ValSup = range("B14")
    ValMoy = range("B15")
    ValInf = range("B16")
    
    For i = 2 To 9 'pour chaque département
        dep = range("A" & i)
        nombre = range("B" & i)
        If IsNumeric(nombre) Then
            If nombre >= ValSup Then
                Couleur = vbGreen
            ElseIf nombre < ValInf Then
                Couleur = vbRed
            Else
                Couleur = vbYellow
            End If
        End If
        ActiveSheet.Shapes("dept" & dep).Fill.ForeColor.RGB = Couleur
    Next i
End Sub

 

[vgendron]

et pour lancer la macro dès que tu modifies une valeur d'un département
dans le code de la feuille 1

Private Sub Worksheet_Change(ByVal Target As range)
    If Intersect(Target, range("B2:B9")) Is Nothing Then Exit Sub
    ColorerShapes
End Sub

 

[sylvanu]

Bonjour François, Vgendron,
Un essai en PJ. Il suffit de modifier une valeur dans B2:B9 pour remettre à jour les couleurs, avec :

Sub Worksheet_Change(ByVal Target As range)
On Error GoTo Fin: If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [B2:B9]) Is Nothing Then
        Application.ScreenUpdating = False
        For Each Sh In ActiveSheet.Shapes
            Nombre = Application.WorksheetFunction.VLookup(Right(Sh.Name, 2), [A2:B9], 2, False)
            With ActiveSheet.Shapes(Sh.Name)
                .Fill.ForeColor.RGB = [A15].Interior.Color
                Select Case Nombre
                    Case Is >= 100: .Fill.ForeColor.RGB = [A14].Interior.Color
                    Case Is <= 49: .Fill.ForeColor.RGB = [A16].Interior.Color
                End Select
            End With
        Next Sh
    End If
Fin:
End Sub

 

[francois95]

Bonjour François, Vgendron,
Un essai en PJ. Il suffit de modifier une valeur dans B2:B9 pour remettre à jour les couleurs, avec :

Sub Worksheet_Change(ByVal Target As range)
On Error GoTo Fin: If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [B2:B9]) Is Nothing Then
        Application.ScreenUpdating = False
        For Each Sh In ActiveSheet.Shapes
            Nombre = Application.WorksheetFunction.VLookup(Right(Sh.Name, 2), [A2:B9], 2, False)
            With ActiveSheet.Shapes(Sh.Name)
                .Fill.ForeColor.RGB = [A15].Interior.Color
                Select Case Nombre
                    Case Is >= 100: .Fill.ForeColor.RGB = [A14].Interior.Color
                    Case Is <= 49: .Fill.ForeColor.RGB = [A16].Interior.Color
                End Select
            End With
        Next Sh
    End If
Fin:
End Sub

Merci Vgendron, et Sylvanu, j'ai essayé les deux fonctionnent parfaitement. Sylvanu, j'aime bien l'idée de recopier la couleur de la cellule Je dois taper comme comme ligne suplementaire pour avoir la police en blanc quand la couleur de la cellule est rouge( c'est pour une meilleure lisibilité)
Je te remercie

 

[sylvanu]

Re,

ligne suplementaire pour avoir la police en blanc quand la couleur de la cellule est rouge

Il suffit d'adapter. Je reprend la couleur de la police en A14:A16 pour l'appliquer aux shapes.

Sub Worksheet_Change(ByVal Target As range)
On Error GoTo Fin: If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [B2:B9]) Is Nothing Then
        Application.ScreenUpdating = False
        For Each Sh In ActiveSheet.Shapes
            Nombre = Application.WorksheetFunction.VLookup(Right(Sh.Name, 2), [A2:B9], 2, False)
            With ActiveSheet.Shapes(Sh.Name)
                .Fill.ForeColor.RGB = [A15].Interior.Color
                .TextFrame2.TextRange.Characters.Font.Fill.ForeColor.RGB = [A15].Font.Color
                Select Case Nombre
                    Case Is >= 100:
                        .Fill.ForeColor.RGB = [A14].Interior.Color
                        .TextFrame2.TextRange.Characters.Font.Fill.ForeColor.RGB = [A14].Font.Color
                    Case Is <= 49:
                        .Fill.ForeColor.RGB = [A16].Interior.Color
                        .TextFrame2.TextRange.Characters.Font.Fill.ForeColor.RGB = [A16].Font.Color
                End Select
            End With
        Next Sh
    End If
Fin:
End Sub

 

[francois95]

Re,

Il suffit d'adapter. Je reprend la couleur de la police en A14:A16 pour l'appliquer aux shapes.

Sub Worksheet_Change(ByVal Target As range)
On Error GoTo Fin: If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [B2:B9]) Is Nothing Then
        Application.ScreenUpdating = False
        For Each Sh In ActiveSheet.Shapes
            Nombre = Application.WorksheetFunction.VLookup(Right(Sh.Name, 2), [A2:B9], 2, False)
            With ActiveSheet.Shapes(Sh.Name)
                .Fill.ForeColor.RGB = [A15].Interior.Color
                .TextFrame2.TextRange.Characters.Font.Fill.ForeColor.RGB = [A15].Font.Color
                Select Case Nombre
                    Case Is >= 100:
                        .Fill.ForeColor.RGB = [A14].Interior.Color
                        .TextFrame2.TextRange.Characters.Font.Fill.ForeColor.RGB = [A14].Font.Color
                    Case Is <= 49:
                        .Fill.ForeColor.RGB = [A16].Interior.Color
                        .TextFrame2.TextRange.Characters.Font.Fill.ForeColor.RGB = [A16].Font.Color
                End Select
            End With
        Next Sh
    End If
Fin:
End Sub

Merci Sylvanu, une dernière chose et après ce devrait être tout bon J'aimerai que les bornes ne soient pas dans le code ( Case Is) mais fassent reference aux cellule B14, B15, B16, j’aimerai m'en servir pour différents indicateurs, sans forcement a avoir a modifier le code mais uniquement les cellules.

 

[sylvanu]

fassent reference aux cellule B14, B15, B16,

La aussi il suffit d'adapter :

Vmax = [B14]: Vmin = [B16]
puis
Case Is >= Vmax
et
Case Is <= Vmin

Vous noterez que la valeur "entre" ne sert à rien le shape est mis de base à "entre" avant d'être coloré par soit "<" soit ">"
NB: J'ai mis aussi les cellules B14:B16 en détection. Si on modifie ces valeurs on modifie en temps réel les shapes.

 

[francois95]

La aussi il suffit d'adapter :

Vmax = [B14]: Vmin = [B16]
puis
Case Is >= Vmax
et
Case Is <= Vmin

Vous noterez que la valeur "entre" ne sert à rien le shape est mis de base à "entre" avant d'être coloré par soit "<" soit ">"
NB: J'ai mis aussi les cellules B14:B16 en détection. Si on modifie ces valeurs on modifie en temps réel les shapes.

Merci Sylvanu, c'est parfait