Discussion :

[Bandoulier]

Bonjour à toutes et à tous,

J'ai fait une feuille Excel sur la mythologie grecque. Elle comporte 288 rectangles (shapes) affichant le nom des dieux ou héros et reliés par des traits (line).
Sur cette feuille, j'ai la liste (AG1:AG288) de tous les noms contenus dans les rectangles.
Je voudrais maintenant faire deux choses :
1) Que le nom de chaque rectangle soit le texte affiché dans le rectangle. J'ai fait cette procédure qui ne fonctionne pas !

Code :

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

1
2
3
For Each Cell In Range("AG1:AG288")
        Selection.ShapeRange.Name = Cell.Value
    Next

2) Je voudrais qu'en mettant le focus sur une cellule de la liste (AG1:AG288) le rectangle portant le même nom se colorie en rouge.
Là … je cale aussi !

Si un(e) spécialiste pouvait me mettre sur la piste, ça m'enlèverait une sacrée épine du pied !
Merci d'avance

[vinc_bilb]

Bonjour,

Ca devrait le faire .... mais il aurait été plus commode de créer les shapes en tant que text box ....

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
Sub TestRect()
 
Dim Wsh As Worksheet
Dim Shap As Shape
 
Set Wsh = ThisWorkbook.Worksheets("Feuil1")
 
If Wsh.Shapes.Count = 0 Then Exit Sub
 
For Each Shap In Wsh.Shapes
    If InStr(1, Shap.Name, "Rectangle", vbTextCompare) > 0 Then
        Debug.Print Shap.Name, Shap.AlternativeText, Shap.Title, Shap.TextFrame.Characters.Text
        Shap.Name = Shap.TextFrame.Characters.Text
    End If
 
Next Shap
End Sub

Bonne journée

[Theze]

Bonjour,

approximativement comme Vincent.
à mettre où tu veux, dans le module de la feuille ou un module standard et à exécuter une seule fois :

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
 
Sub Renommer()
 
    Dim S As Shape
    Dim I As Integer
 
    For Each S In ActiveSheet.Shapes
 
        'gère les erreurs dues au Shapes "Line"
        On Error Resume Next
 
        S.Name = S.TextFrame.Characters.Text
 
        'fait coincider les noms de shape avec les valeurs des cellules
        Cells(I, 12).Value = S.Name
 
    Next S
 
End Sub

à mettre dans le module de la feuille et à adapter à tes besoins. Attention, ici la colonne cible est la colonne L :

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
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
    Dim S As Shape
    Dim I As Integer
 
    'seulement la colonne L (à adapter...)
    If Target.Column <> 12 Then Exit Sub
 
    'une seule cellule doit être sélectionnée
    If Target.Count > 1 Then Exit Sub
 
    'gère l'erreur des Shapes "Line" et du nom inexistant
    On Error Resume Next
 
    'efface la couleur rouge
    For Each S In Me.Shapes
 
        S.Fill.ForeColor.RGB = RGB(255, 255, 255)
 
    Next S
 
    'doit contenir un nom
    If Target.Value = "" Then Exit Sub
 
    'colore le shape correspondant en rouge
    Me.Shapes(Target.Value).Fill.ForeColor.RGB = RGB(255, 0, 0)
 
End Sub

Hervé.

[pijaku]

Bonjour tout le monde,

J'en étais arrivé aux mêmes conclusions et au même résultat au niveau du code.
Je ne le remet pas, cela ferais doublon.

Mon intervention se limitera donc à prévenir l'utilisateur des fautes d'orthographe.
En colonne L on trouve Eurynomée que l'on trouve orthographié comme ceci dans le Shape : Eurynomé

En cas d'automatisation précise, cela risque de planter.

Cordialement,

Pijaku

[Theze]

Bonsoir Pijaku,

Mon intervention se limitera donc à prévenir l'utilisateur des fautes d'orthographe.
En colonne L on trouve Eurynomée que l'on trouve orthographié comme ceci dans le Shape : Eurynomé

C'est ce que j'ai constaté aussi et c'est pour cette raison que dans mon code je fais coïncider le nom des shapes avec les cellules :

Code :

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

1
2
3
4
5
 
...
'fait coincider les noms de shape avec les valeurs des cellules
Cells(I, 12).Value = S.Name
...

Hervé.

[Bandoulier]

Vinc_Bilb
J'ai essayé la 1ère procédure : Elle plante avec message "Propriété ou méthode non gérée par cet objet" et elle met "Debug.Print Shap.Name, Shap.AlternativeText, Shap.Title, Shap.TextFrame.Characters.Text" en surbrillance.

Thèze
J'ai essayé la 1ère procédure : Elle marche ! Mais j'avoue ne pas comprendre la ligne "Cells(I, 12).Value = S.Name" d'autant plus que I n'est incrémenté nulle part. Si tu as le temps explique-moi !
Je n'ai pas encore essayé le 2ème procédure, je te tiens au courant dès mes essais finis.

Pikaju
Merci pour ta remarque, mais l'erreur est due à la précipitation pour faire le fichier exemple. Il va de soi que dans le vrai fichier les noms concordent.

Merci encore à tous les 3

[Theze]

Oups, là j'ai foiré grave

voici le code modifié :

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
 
Sub Renommer()
 
    Dim S As Shape
    Dim I As Integer
 
    For Each S In ActiveSheet.Shapes
 
        'gère les erreurs dues au Shapes "Line"
        On Error Resume Next
 
        S.Name = S.TextFrame.Characters.Text
 
 
        'fait coincider les noms de shape avec les valeurs des cellules
        If InStr(S.Name, "Line") = 0 Then
 
            I = I + 1
            Cells(I, 12).Value = S.Name
 
        End If
 
    Next S
 
End Sub

Désolé !

Hervé.