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

[Tristan2222]

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]

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

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]

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

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]

Une V2 où on peut choisir la couleur.

 

[Tristan2222]

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]

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

        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]

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]

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]

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

 

[sylvanu]

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]

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]

Je viens de réessayer avec ce code :

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]

Je viens de réessayer avec ce code :

Sur quel fichier ?

 

[Tristan2222]

Celui ci

 

[Tristan2222]

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 !