Changer la couleur d'une forme liée à une cellule

**yoddd** · 21/04/2017, 21h28

Bonjour,
J'essaie de faire de la cartographie dans excel. J'aimerai faire évoluer les couleurs de ma carte à l'aide d'une zone de liste déroulante. Chaque date est liée à une cellule qui contient le nom d'une couleur( la couleur peut varier dans une même case). J'aimerai faire apparaître les couleurs sur la carte. Pour ce faire, la base de données contient dans la colonne T : les dates, dans la colonne U les couleurs du département du var, dans la colonne V les couleurs des alpes maritimes et la colonne W les couleurs du vaucluse. La liste déroulante détient la colonne des dates. Le choix de la liste déroulante donne une valeur unique pour tous les départements. cette valeur est ensuite transmise, à trois cellule qui vont faire sortir la couleur de chaque département. Par exemple, pour le 01/01/2012 à 03h00 : la cellule Q35 va donner la couleur orange pour le var, la cellule R35 va donner la couleur rouge pour les alpes maritimes et la cellule S35 va donner la couleur rouge pour le vaucluse. Le but est que la couleur de chaque cellule colore le département lié. Pouvez vous m'aider ?

Je vous remercie par avance.

**jerome.vaussenat** · 22/04/2017, 19h26

Salut,

je te propose une solution avec du VBA. Tout est dans la pièce jointe.

Ci dessous le code pour information.
Pour les puriste, oui je sais, les .select, c'est pas beau. Mais ici, j'évite des lignes trop longues.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Sub couleur()
'
' couleur Macro
' déclaration des variables pour les trois départements
Dim coul_Var As String
Dim coul_AM As String
Dim coul_Vaucluse As String
 
'on stocke la couleur de la feuille dans la variable
coul_Var = LCase(Range("q35").Value)
coul_AM = LCase(Range("r35").Value)
coul_Vaucluse = LCase(Range("s35").Value)
'changement de la couleur pour les alpes maritime
    ActiveSheet.Shapes.Range(Array("Freeform 2395")).Select 'AM
    Select Case coul_Var
        Case Is = "orange"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 192, 0) 'orange
        Case Is = "rouge"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0) 'rouge
        Case Is = "vert"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 80) 'vert
        Case Is = "jaune"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 0)  'jaune
        Case Is = "violet"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(112, 48, 160)  'violet
    End Select
'changement de la couleur pour le Var
    ActiveSheet.Shapes.Range(Array("Freeform 2399")).Select 'var
    Select Case coul_AM
        Case Is = "orange"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 192, 0) 'orange
        Case Is = "rouge"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0) 'rouge
        Case Is = "vert"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 80) 'vert
        Case Is = "jaune"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 0)  'jaune
        Case Is = "violet"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(112, 48, 160)  'violet
    End Select
'changement de la couleur pour le vaucluse
    ActiveSheet.Shapes.Range(Array("Freeform 2404")).Select 'vaucluse
    Select Case coul_Vaucluse
        Case Is = "orange"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 192, 0) 'orange
        Case Is = "rouge"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0) 'rouge
        Case Is = "vert"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 80) 'vert
        Case Is = "jaune"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 0)  'jaune
        Case Is = "violet"
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(112, 48, 160)  'violet
    End Select
' a la fin retour dans la feuille
    Range("R12").Select
End Sub