Discussion :

[Leb95]

Bonjour et merci de me lire,

Je suis nouveau et souvent je ne fais "que" lire des posts pour m'aider et souvent j'arrive à faire ce que je souhaite (non sans mal) sans sollicité l'aide de la communauté.
Je cherche à faire quelque chose qui pourrait vous paraitre simple (je suis nul en VBA mais j'essai, j'adapte et souvent j'y arrive mais je ne suis bon qu'a "bidouiller", pas a créer).

Je plante le décor :
Sur un onglet (appelé "carte") J'ai une carte qui est composer en faite de plus de 400 shapes tous portant le nom de commune (ex : Sannois, Taverny, Cergy, etc.).
Sur un autre onglet (appelé "commune", je fais dans l'originalité ) j'ai un tableau avec en colonne A mes 400 communes (le nom est identique a chaque "shape" de l'onglet "carte" du coup), en B le nombre de RDV (qui sert pour la colonne C) et en C un nombre compris en 1 et 3 (j'appelle ce critère l'"indice de charge"). La valeur en C serait pour la couleur : 1 = vert, 2 = orange, 3 = rouge (pour le moment je ne prévoit que 3 couleurs).

J'ai trouver plusieurs pistes que j'ai abandonné faute de comprendre le code et donc impossible de l'adapter... et systématique, les Shapes avait une suite de chiffre, ce que je n'ai pas.

Ce que je cherche donc à faire c'est une macro qui, prend chaque ligne dans mon tableau "commune" (boucle?) pour colorier chaque shapes correspondant, dans mon onglet "carte", suivant le nom de la commune pour colorier l'intérieur de mon Shape d'une couleur en rapport a mon "indice de charge".

Pourriez vous m'aider ?
Au besoin je peux fournir mon fichier sans macros pour plus de sécurité.

Merci a vous

[Nain porte koi]

Hello,

le fichier serait le bienvenu (avec ou sans macro), c'est toujours difficile de faire dans l'imaginaire

[Leb95]

Hello,

le fichier serait le bienvenu (avec ou sans macro), c'est toujours difficile de faire dans l'imaginaire

J'ai justement vu qu'il était malvenu de mettre un fichier sans y être invité

je n'ai pas précisé que j'ai un bout de code qui semble fonctionné mais c'est très certainement très mal écris...

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub test()
On Error Resume Next
Dim cell As Range
For Each cell In Sheets("commune").Range("A2:A450")
'MsgBox cell.Value
If cell.Offset(, 1) > 100 Then
Sheets("carte").Shapes(cell.Value).Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf cell.Offset(, 1) > 50 Then
Sheets("carte").Shapes(cell.Value).Fill.ForeColor.RGB = RGB(255, 255, 0)
ElseIf cell.Offset(, 1) < 50 Then
Sheets("carte").Shapes(cell.Value).Fill.ForeColor.RGB = RGB(0, 255, 0)
End If
Next cell
End Sub

[EricDgn]

Bonjour,

Une façon de faire en supposant que les cellules G1:G3 de la feuille Commune ont les couleurs 1, 2 et 3 (vert,orange, rouge):

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub ColorerShapes()
    Dim kR As Long, kColor As Long
    Worksheets("Commune").Select
    kR = 2
    On Error Resume Next           '--- erreur si aucun shape ayant le nom cherché
    With Worksheets("Carte")
        While Range("A" & kR) <> ""
            .Shapes(Range("A" & kR)).Fill.ForeColor.RGB = Range("G" & Range("C" & kR)).Interior.Color
            kR = kR + 1
        Wend
    End With
    On Error GoTo 0
End Sub

Bien cordialement.

[Nain porte koi]

@EricDgn, j'aime bien ta solution, elle est simple et élégante.
Moi j'avais ça

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
Option Explicit
 
Sub test()
 
    On Error Resume Next
 
    Dim Num_Ligne As Single
    Dim Couleur As Single
    Dim Nom_Commune As String
    Dim IDC As Byte
    Dim Shapes_Manquantes As String
 
    For Num_Ligne = 2 To Sheets("commune").Cells(Rows.Count, 1).End(xlUp).Row
 
        Nom_Commune = Sheets("commune").Cells(Num_Ligne, 1)
        IDC = Sheets("commune").Cells(Num_Ligne, 3)
 
        Select Case IDC
        Case 3
            Couleur = RGB(255, 0, 0)
        Case 2
            Couleur = RGB(255, 255, 0)
        Case 1
            Couleur = RGB(0, 255, 0)
        End Select
 
        Sheets("carte").Shapes(Nom_Commune).Fill.ForeColor.RGB = Couleur
        If Err.Number <> 0 Then
            Shapes_Manquantes = Shapes_Manquantes & vbLf & Nom_Commune
        End If
 
    Next Num_Ligne
 
    If Len(Shapes_Manquantes) <> 0 Then
        ' Debug.Print "Shape(s) manquant(s) : " & Shapes_Manquantes
        MsgBox "Shape(s) manquant(s) : " & Shapes_Manquantes
    End If
 
End Sub

Ca indique quelle(s) shape(s) manque(nt) à la fin

[EricDgn]

Bonjour,

Un petit supplément permettant d'effectuer la liste de toutes les formes (il y en a un paquet!) et de retrouver la position d'une forme en partant d'un double-clic sur son nom dans ladite liste.

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
58
59
60
61
62
63
64
65
'--- dans un module normal
Sub ListerToutesLesFormes()
    Dim ws As Worksheet, shp As Shape, kR1 As Long, kR2 As Long, i As Long, s As String
    Set ws = ThisWorkbook.Worksheets("Liste")
    kR1 = 2
    kR2 = 2
    On Error Resume Next
    Debug.Print "Nombre total de formes : " & ws.Shapes.Count
    For Each shp In ThisWorkbook.Worksheets("Carte").Shapes
        Debug.Print "Nom: " & shp.Name & ", Type: " & shp.Type & ", ID: " & shp.ID
        '--- Si cette forme contient des sous-formes (groupe)
        If shp.Type = msoGroup Then
            Debug.Print "  est un groupe contenant " & shp.GroupItems.Count & " éléments :"
            For i = 1 To shp.GroupItems.Count
                With shp.GroupItems(i)
                    If .Type = 1 Then                   '--- rectangle ou ellipse
                        Range("A" & kR1) = .Name
                        Range("B" & kR1) = .Type
                        Range("C" & kR1) = .Top + .Height / 2
                        Range("D" & kR1) = .Left + .Width / 2
                        s = .TextFrame.Characters.Text
                        Range("E" & kR1) = s
                        Range("F" & kR1) = Mid(s, InStr(s, Chr(10)) + 1)
                        kR1 = kR1 + 1
                    Else                                '--- autre, normalement 5 = textbox
                        Range("G" & kR2) = .Name
                        Range("H" & kR2) = .Type
                        Range("I" & kR2) = .Top + .Height / 2
                        Range("J" & kR2) = .Left + .Width / 2
                        kR2 = kR2 + 1
                    End If
                End With
 
            Next i
        End If
    Next shp
    On Error GoTo 0
End Sub
 
'--- dans la feuille Liste
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Column <> 1 And Target.Column <> 7 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    Dim oShape As Object
    ThisWorkbook.Worksheets("Carte").Select
    Set oShape = ThisWorkbook.Worksheets("Carte").Shapes("GroupeCarte").GroupItems(Target)
    Debug.Print Target, oShape.Top, oShape.Left
    '--- pose la flèche près du coin supérieur gauche de la forme
    ThisWorkbook.Worksheets("Carte").Shapes("Ceci").Select
    Selection.Top = oShape.Top - Selection.Height / 2
    Selection.Left = oShape.Left - Selection.Width / 2
    '--- repositionne la zone affichée
    If Selection.topLeftCell.Row > (Application.ActiveWindow.VisibleRange.Rows.Count / 2) Then
        Application.ActiveWindow.ScrollRow = Selection.topLeftCell.Row - Application.ActiveWindow.VisibleRange.Rows.Count / 2
    Else
        Application.ActiveWindow.ScrollRow = 1
    End If
    If Selection.topLeftCell.Column > Application.ActiveWindow.VisibleRange.Columns.Count / 2 Then
        Application.ActiveWindow.ScrollColumn = Selection.topLeftCell.Column - Application.ActiveWindow.VisibleRange.Columns.Count / 2
    Else
         Application.ActiveWindow.ScrollColumn = 1
    End If
    '---
    oShape.Select
End Sub

Cordialement.

[Leb95]

Merci beaucoup pour vos retours !
Je ne comprend pas tout mais je vais faire comme j'aime toujours faire : essayer de comprendre et appliquer (et au besoin m'adapter).

J'ai même mieux que ce que je pensais grâce a vous (super !).
Encore merci