Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Rectangles (shapes) à renommer

B

Bandoulier

XLDnaute Junior
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
 
Trier par date Trier par votes

phlaurent55

Nous a quittés en 2020
Repose en paix
Re : Rectangles (shapes) à renommer

Bonjour Bandoulier,

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

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
 
Vote positif 0 Vote négatif

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : Rectangles (shapes) à renommer

Bonjour,


Code: 
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

Code: 
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
 

Pièces jointes

  • Exemple-1.xls
    74.5 KB · Affichages: 53
  • Exemple-1.xls
    74.5 KB · Affichages: 60
  • Exemple-1.xls
    74.5 KB · Affichages: 57
Dernière édition:
Vote positif 0 Vote négatif

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : Rectangles (shapes) à renommer

Voir PJ

JB
 

Pièces jointes

  • ShapesColor.xls
    76.5 KB · Affichages: 42
  • ShapesColor.xls
    76.5 KB · Affichages: 42
  • ShapesColor.xls
    76.5 KB · Affichages: 40
Dernière édition:
Vote positif 0 Vote négatif
L

laetitia90

XLDnaute Barbatruc
Re : Rectangles (shapes) à renommer

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

Code: 
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
 
Vote positif 0 Vote négatif

Modeste geedee

XLDnaute Barbatruc
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é...
 

Pièces jointes

  • divinitées-exemple.xls
    197 KB · Affichages: 34
Vote positif 0 Vote négatif

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : Rectangles (shapes) à renommer

Bonjour,

Affichage d'une bulle au survol des shapes.

JB
 

Pièces jointes

  • ShapesColor.xls
    87 KB · Affichages: 46
  • ShapesColor.xls
    87 KB · Affichages: 55
  • ShapesColor.xls
    87 KB · Affichages: 46
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…