Manipulation sélection dynamique de formes

Version imprimable

22/09/2015, 01h52
Martin456

1 pièce(s) jointe(s)

Manipulation sélection dynamique de formes

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:

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.

Pièce jointe 188522 Pièce jointe 188522

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:

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

Bonjour,

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

Code:

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:

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

25/09/2015, 00h27
Martin456

Vos solutions fonctionnent parfaitement !

Merci beaucoup !