Rectangles (shapes) à renommer

[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 !

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

 

[phlaurent55]

Re : Rectangles (shapes) à renommer

Bonjour Bandoulier,

Si un(e) spécialiste pouvait me mettre sur la piste................

Je n'ai pas la prétention d'être le spécialiste qui va solutionner le problème
........ mais juste pour te signaler que si tu joins ton fichier tu augmentera considérablement les chances d'avoir un réponse adaptée à ton besoin

un bout de fichier représentatif contenant 10 shapes et des données de AG1--> AG10 fera l'affaire
et évitera au répondeur de devoir tout construire afin de tester

à+
Philippe

 

[Bandoulier]

Re : Rectangles (shapes) à renommer

Merci Laurentph55, mais je ne sais pas comment faire ... Il n'y a pas de bouton "Insérer un fichier" !

 

[mutzik]

Re : Rectangles (shapes) à renommer

bonjour,

en mode avancé, il y a un petit trombone, il faut chercher le fichier, appuyer sur envoyer et en dernier 'fermer la fenetre'

 

[Bandoulier]

Re : Rectangles (shapes) à renommer

Ci-joint un fichier exemple !

 

[laetitia90]

Re : Rectangles (shapes) à renommer

bonjour tous
je vais regarder patience

 

[BOISGONTIER]

Re : Rectangles (shapes) à renommer

Bonjour,

Sub essai()
  For Each s In ActiveSheet.Shapes
    If s.Type = 1 Then
       tmp = s.TextFrame.Characters.Text
       If Err = 0 Then s.Name = s.TextFrame.Characters.Text
    End If
  Next s
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([L1:L15], Target) Is Nothing Then
    For Each s In ActiveSheet.Shapes
      If s.Type = 1 Then s.Fill.ForeColor.RGB = RGB(255, 255, 255)
    Next s
    On Error Resume Next
    ActiveSheet.Shapes(Target).Fill.ForeColor.RGB = RGB(255, 0, 0)
  End If
End Sub

JB

 

[Bandoulier]

Re : Rectangles (shapes) à renommer

merci beaucoup Boisgontier mais ...
J'ai essayé la 1ère procédure, mais ça plante avec message "Permission refusée" et ça met "s.TextFrame.Characters.Text" en surbrillance !

 

[BOISGONTIER]

Re : Rectangles (shapes) à renommer

Voir PJ

JB

 

[Bandoulier]

Re : Rectangles (shapes) à renommer

Merci Boisgontier !
Ca marche !!!

 

[laetitia90]

Re : Rectangles (shapes) à renommer

re tous jb
cela devrait marcher sans renommer enfin je pense avec 2003 je sais pas???

Private Sub Worksheet_SelectionChange(ByVal T As Range)
If Not Intersect(T, [l1:l15]) Is Nothing And T.Count = 1 Then
 For Each s In ActiveSheet.Shapes
   If s.Type = 1 Then
    s.Fill.ForeColor.RGB = RGB(255, 255, 255)
    If s.TextFrame.Characters.Text = T Then s.Fill.ForeColor.RGB = RGB(248, 36, 14)
  End If
  Next
 End If
End Sub

 

[Modeste geedee]

Re : Rectangles (shapes) à renommer

Bonsour®
comme j'arrive un peu tard
et le problème de renommage étant résolu...
pour le fun, les élucubrations qui m'ont inspiré...

 

[BOISGONTIER]

Re : Rectangles (shapes) à renommer

Bonjour,

Affichage d'une bulle au survol des shapes.

JB