Discussion :

[Martin456]

Bonjour,


Je réalise une carte du monde qui doit permettre de visualiser quel partenaire est responsable de quel pays. Il y a donc plusieurs pays (une centaine), et plusieurs responsables (une vingtaine). Dans mon tableur, les pays sont des formes issues de D-maps (mais pour l'exemple j'ai juste mis des rectangles ici).

Pour qu'il soit facile de savoir graphiquement qui s'occupe de quelle zone j'ai un code couleur qui colorie les pays en fonction du responsable en charge.

Le soucis est que je ne sais pas comment colorier un ensemble de formes qui est amené à changer. Je pourrais faire une ligne de code par forme, mais ce serait trop long pour une centaine de pays.

Je souhaite donc savoir comment faire en sorte que tous les pays qui répondent à la condition responsable="Louis" soient automatiquement coloriés en orange, tous ceux répondant à la condition responsable="Matthieu" soient coloriés en rouge, etc.

Jusqu'ici j'ai ça, mais ce n'est pas du tout dynamique :

Code :

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

Worksheets("PAYS").Shapes.Range(Array("BRESIL", "ARGENTINE")).Fill.ForeColor.RGB = RGB(245, 180, 15)

Voilà le type de fichier sur lequel je suis amené à travailler.


D'avance merci, parce que là, je bloque !


Cordialement,



Martin.


MAPEMONDE.xlsmMAPEMONDE.xlsm

[Philippe Tulliez]

Bonjour,
Une idée parmi d'autres.
La liste des pays dans une plage à une colonne nommée T_Pays dont chaque cellule est colorée en fonction du responsable.
Procédure à adapter avec une table à plusieurs colonnes dont l'une contiendrait par exemple le nom du responsable qui permettrait d'aller chercher dans une autre table la couleur correspondante par responsable avec éventuellement une Mise en forme conditionnelle.

Code :

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

1
2
3
4
5
6
7
8
9
Sub ColorCountry()
 Dim shpe As Shape, rng As Range
 Set rng = Range("T_Pays")
 For Each shpe In Worksheets("Pays").Shapes
  On Error Resume Next
  shpe.Fill.ForeColor.RGB = rng(WorksheetFunction.Match(shpe.Name, rng, 0)).Interior.Color
  On Error GoTo 0
 Next
End Sub

[Theze]

Bonjour,

Un peu dans le même esprit que Philippe mais en utilisant tes tableaux dynamiques :

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
 
Sub Test()
 
    Dim PlageNoms As Range
    Dim PlagePays As Range
    Dim Cel As Range
    Dim CelCherche As Range
    Dim Fe As Worksheet
 
    Set Fe = Worksheets("PAYS")
 
    Set PlagePays = Fe.ListObjects(1).DataBodyRange
    Set PlageNoms = Fe.ListObjects(2).DataBodyRange
 
    For Each Cel In Fe.Range(PlagePays.Columns(2).Address)
 
        Set CelCherche = PlageNoms.Find(Cel.Value, , xlValues, xlWhole)
 
        If Not CelCherche Is Nothing Then
 
            Select Case CelCherche.ListObject.HeaderRowRange(CelCherche.Column - PlageNoms.Column + 1).Value
 
                Case "Louis": Fe.Shapes(Cel.Value).Fill.ForeColor.RGB = RGB(245, 180, 15)
 
                Case "Matthieu": Fe.Shapes(Cel.Value).Fill.ForeColor.RGB = RGB(255, 125, 100)
 
                'Case etc...
 
            End Select
 
        End If
 
    Next Cel
 
End Sub

Selon le nombre de responsables, peut être utiliser un tableau stockant les valeurs RGB et attribuer ces dernières de façon ordinale :

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
 
Sub Test()
 
    Dim PlageNoms As Range
    Dim PlagePays As Range
    Dim Cel As Range
    Dim CelCherche As Range
    Dim Fe As Worksheet
    Dim Index As Integer
 
    Dim Tbl
 
    Tbl = Array(&H80FF&, &HFF00FF, &HFF00&) 'correspondant de façon ordinale aux responsables
 
    Set Fe = Worksheets("PAYS")
 
    Set PlagePays = Fe.ListObjects(1).DataBodyRange
    Set PlageNoms = Fe.ListObjects(2).DataBodyRange
 
    For Each Cel In Fe.Range(PlagePays.Columns(2).Address)
 
        Set CelCherche = PlageNoms.Find(Cel.Value, , xlValues, xlWhole)
 
        If Not CelCherche Is Nothing Then
 
            Index = CelCherche.ListObject.HeaderRowRange(CelCherche.Column - PlageNoms.Column + 1).Column - 13
 
            Fe.Shapes(Cel.Value).Fill.ForeColor.RGB = Tbl(Index)
 
        End If
 
    Next Cel
 
End Sub

[Martin456]

Vos solutions fonctionnent parfaitement !

Merci beaucoup !