XL 2016 Changer la couleur d'une forme en fonction d'une valeur

Tristan2222 · 14 Novembre 2022

Bonjour à tous,

J'aimerai créer une carte dynamique par régions, dont la couleur des régions change en fonction de la valeur en % sur le tableau.

J'ai essayer plusieurs solutions trouvées en faisant des recherches mais je n'ai rien trouvé qui me convient vraiment, mes compétences en vba étant faibles ca ne m'aide pas non plus.

Je suis donc ouvert a vos propositions, merci d'avance !

sylvanu · 14 Novembre 2022

Bonjour Tristan, et bienvenu sur XLD,
Un essai avec une procédure très simple :

VB:

Sub Colore()
    Dim Maxi, L, Nom, V, Couleur
    Maxi = Application.Max([D4:D16])    ' Max des % français
    For L = 4 To 16
        Nom = Cells(L, "B")             ' Nom de la région et du shape
        V = Cells(L, "D") / Maxi        ' Valeur normalisée ( 0 à 100%)
        Couleur = RGB(255 - Int(255 * V), 255, Int(255 - 255 * V))  ' Couleur dégradé vert
        Cells(L, "D").Interior.Color = Couleur                      ' Couleur des cellules C et D
        Cells(L, "C").Interior.Color = Couleur
        On Error Resume Next
        Sheets("Feuil1").Shapes(Nom).Fill.ForeColor.RGB = Couleur   ' Couleur du shape
    Next L
End Sub

J'ai limité l'analyse que sur la France pour le calcul du dégradé.

Tristan2222 · 14 Novembre 2022

sylvanu à dit:

Bonjour Tristan, et bienvenu sur XLD,
Un essai avec une procédure très simple :

VB:

Sub Colore()
    Dim Maxi, L, Nom, V, Couleur
    Maxi = Application.Max([D4:D16])    ' Max des % français
    For L = 4 To 16
        Nom = Cells(L, "B")             ' Nom de la région et du shape
        V = Cells(L, "D") / Maxi        ' Valeur normalisée ( 0 à 100%)
        Couleur = RGB(255 - Int(255 * V), 255, Int(255 - 255 * V))  ' Couleur dégradé vert
        Cells(L, "D").Interior.Color = Couleur                      ' Couleur des cellules C et D
        Cells(L, "C").Interior.Color = Couleur
        On Error Resume Next
        Sheets("Feuil1").Shapes(Nom).Fill.ForeColor.RGB = Couleur   ' Couleur du shape
    Next L
End Sub

J'ai limité l'analyse que sur la France pour le calcul du dégradé.

Bonjour !

Merci beaucoup pour votre réponse, je pense pouvoir faire ce que je souhaite avec cela.

Bonne journée à vous !

sylvanu · 14 Novembre 2022

Une V2 où on peut choisir la couleur.

Tristan2222 · 16 Novembre 2022

Bonjour,

Encore merci pour vos réponses.

Votre code est exactement ce que je cherchait , cependant j'ai un petit soucis : j'aimerai que lorsque la valeur est nulle le dpt associé soit blanc / non coloré, seulement ici il est forcément coloré même avec la valeur nulle.

J'ai donc essayé de modifier en ce sens mais rien de concluant.

Avez-vous une idée ?

sylvanu · 16 Novembre 2022

Bonjour,
Difficile à imaginer puisque dans votre tableau, aucune valeur n'était nulle.
Un essai en PJ, où j'ai rajouté :

VB:

        If Cells(L, "D") = 0 Then
            Sheets("Feuil1").Shapes(Nom).Fill.ForeColor.RGB = vbWhite   ' Blanc si nul
        Else
            Sheets("Feuil1").Shapes(Nom).Fill.ForeColor.RGB = Couleur   ' Couleur du shape
        End If

Tristan2222 · 16 Novembre 2022

Merci pour votre retour.

Effectivement, je l'ai changé pour avoir les données par dpt (bcp plus pertinent).

J'ai essayer ce code mais ca ne fonctionne pas pour ma nouvelle carte...

Je ne comprends pas pourquoi, j'avais essayé quelque chose comme ça également mais sans résulats.

sylvanu · 16 Novembre 2022

Ca ne peux pas marcher avec votre nouvelle carte, on ne peut pas cliquer sur un département.
Pour cela, il faut utiliser une carte où chaque département est un shape sur le quel on peut cliquer, ce qui déclenche la macro.
En PJ un ex de carte avec les département accessibles. ( mais il n'y a pas les DOM-TOM. )

Tristan2222 · 16 Novembre 2022

J'avais compris cette logique, c'est bizarre parce que je peux les sélectionner (je les ai toutes renommées d'ailleurs)

sylvanu · 16 Novembre 2022

J'ai oublié, il faut qu'à chaque département le dessin soit associé à la macro.
On fait clic droit sur le département puis Affecter une macro.

Tristan2222 · 16 Novembre 2022

Etes vous sûr que cela soit nécessaire ? Car tout fonctionne très bien sans a priori, mon seul problème est le fait que les valeurs nulles ne soient pas blanches..

Tristan2222 · 16 Novembre 2022

Je viens de réessayer avec ce code :

VB:

Public C
Sub Colore()
    Dim Maxi, L, Nom, V, Couleur
    n = 240
    Maxi = Application.Max([D4:D112])    ' Max des % français
    For L = 4 To 112
        Nom = Cells(L, "B")             ' Nom de la région et du shape
        V = Cells(L, "D") / Maxi        ' Valeur normalisée ( 0 à 100%)
        If C = 0 Or C = "" Then C = "vert"
        If C = "vert" Then Couleur = RGB(n - Int(n * V), 255, Int(n - n * V)) ' Couleur dégradé vert
        If C = "rouge" Then Couleur = RGB(255, n - Int(n * V), Int(n - n * V)) ' Couleur dégradé rouge
        If C = "bleu" Then Couleur = RGB(n - Int(n * V), Int(n - n * V), 255) ' Couleur dégradé bleu
        Cells(L, "D").Interior.Color = Couleur                      ' Couleur des cellules C et D
        Cells(L, "C").Interior.Color = Couleur
        On Error Resume Next
        If Cells(L, "D") = 0 Then
            Sheets("Feuil1").Shapes(Nom).Fill.ForeColor.RGB = vbWhite   ' Blanc si nul
        Else
            Sheets("Carte").Shapes(Nom).Fill.ForeColor.RGB = Couleur   ' Couleur du shape
        End If
    Next L
End Sub
Sub Cvert(): C = "vert": Colore: End Sub
Sub Crouge(): C = "rouge": Colore: End Sub
Sub Cbleu(): C = "bleu": Colore: End Sub

Ca fonctionne seulement les dpt nuls sont rouges très clair au lieu de blanc (peu importe la couleur choisie)....

sylvanu · 16 Novembre 2022

Tristan2222 à dit:
Je viens de réessayer avec ce code :

Sur quel fichier ?

Tristan2222 · 16 Novembre 2022

Celui ci

Tristan2222 · 16 Novembre 2022

Autant pour moi, je n'avais pas modifié le nom de la feuille pour le code, il fonctionne très bien !

Merci infiniment pour votre aide, vous m'avez épargné des heures de galère !

XL 2016 Changer la couleur d'une forme en fonction d'une valeur

Tristan2222

XLDnaute Nouveau

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

Tristan2222

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Pièces jointes

Tristan2222

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Pièces jointes

Tristan2222

XLDnaute Nouveau

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

Tristan2222

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Tristan2222

XLDnaute Nouveau

Tristan2222

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Tristan2222

XLDnaute Nouveau

Pièces jointes

Tristan2222

XLDnaute Nouveau

Discussions similaires