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