Création de forme automatisée

Question

J'ai un tableau listant des donnés et pour chacune de ces donnés j'aimerai qu'automatiquement Excel me créer une petite étiquette (forme rectangulaire en gros) avec inscrit le nom de la donné dessus. J'imagine qu'il faut parcourir le tableau et pour chaque ligne créer une shape et derrière lui associer un texte mais concrètement je peine à avoir une idée pour le coder (connaissance du VBA très limité). Merci d'avance si vous pouvez m'aider ...

21Formatic · Accepted Answer

Bon, OK, ça peut donner un truc du genre alors :)

Sub Macro1()
Dim Sh As Shape, forme As Object

'Boucle sur les formes de la feuille active
    For Each Sh In Feuil1.Shapes
        'Vérifie si le nom de la forme commence par "Rectangle".
        If Sh.Name Like "Rectangle" & "*" Then Sh.Delete
    Next
'boucle sur toutes les cellules qui contiennent des noms d'entreprise
For Each Cell In Range("N3:N" & Feuil1.Range("N3").End(xlDown).Row)
'définit le nom de la forme qu'on va insérer (pour plus tard y faire référence éventuellement)
    nom = "Rectangle" & Cell.Row - 2
'on créé un rectangle et on lui donne le nom
    Set forme = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 695.6249606299, 196.8749606299, _
        126.562519685, 44.062519685)

With forme
    .Name = nom
    .Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
With .TextFrame2
    .TextRange.Characters.Text = Cell.Value & Chr(13) & Cell.Offset(, 1).Value
    .VerticalAnchor = msoAnchorTop
    .VerticalAnchor = msoAnchorMiddle
    .TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    .TextRange.Characters(1, 7).ParagraphFormat.FirstLineIndent = 0
    .TextRange.Characters(1, 7).ParagraphFormat.Alignment = msoAlignCenter
    .TextRange.Characters(8, 9).ParagraphFormat.FirstLineIndent = 0
    .TextRange.Characters(8, 9).ParagraphFormat.Alignment = msoAlignCenter
End With
End With
'on positionne la forme au dessus d'une cellule
    forme.Top = Range(Cell.Offset(, 5).Value).Top
    forme.Left = Range(Cell.Offset(, 5).Value).Left
    Next
End Sub

Merci LouReed pour la précision et la gymnastique qui en a découlé... Ça oblige à s'éloigner un peu de l'enregistreur de macro et à se recentrer sur l'essentiel ^^

21Formatic · Answer

Bonjour, c'est possible de t'aider... Mais si tu ne mets pas un fichier avec un exemple représentatif de tes données et de ce que tu attends comme résultat, ça va être compliqué.....

21Formatic · Answer

Re, Ça risque de ne pas être facile de positionner les rectangles ensuite. Qu'est-ce qui va te permettre de le positionner à tel ou tel endroit ...

21Formatic · Answer

Tiens, du bidouillage amateur pour commencer, avant que des pros ne passent par là ;)

On peut se passer de la sélection de la forme, mais je n'ai pas réussi.

Sub Macro1()
Dim Sh As Shape

    'Boucle sur les formes de la feuille active
    For Each Sh In Feuil1.Shapes
        'Vérifie si le nom de la forme commence par "Rectangle".
        If Sh.Name Like "Rectangle" & "*" Then Sh.Delete
    Next
'boucle sur toutes les cellules qui contiennent des noms d'entreprise
For Each Cell In Range("N3:N" & Feuil1.Range("N3").End(xlDown).Row)
'définit le nom de la forme qu'on va insérer (pour plus tard y faire référence éventuellement)
    nom = "Rectangle" & Cell.Row - 2
'on créé un rectangle et on lui donne le nom
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 695.6249606299, 196.8749606299, _
        126.562519685, 44.062519685).Name = nom
'on sélectionne le rectangle
    ActiveSheet.Shapes.Range(nom).Select

'on remplit le rectangle en blanc
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With

'on inscrit des données relatives aux interventions dans le rectangle
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
    Cell.Value & Chr(13) & Cell.Offset(, 1).Value
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorTop
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle

'on écrit en noir dans le rectangle
    With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0
        .Solid
    End With

'on centre la 1ère ligne
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 7). _
        ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignCenter
    End With
'on centre la 2ème
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(8, 9). _
        ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignCenter
    End With
'on positionne la forme au dessus d'une cellule
    Selection.Top = Range(Cell.Offset(, 5).Value).Top
    Selection.Left = Range(Cell.Offset(, 5).Value).Left
    Next
End Sub

21Formatic · Answer

Beaucoup de ces lignes ont été générées par l'enregistreur de macro. Elles ne sont pas toutes forcément utiles dans l'absolu.

Tu peux lancer la macro depuis l'éditeur VBA en faisant un pas à pas détaillé avec la touche F8.

À chaque appui sur la touche F8, tu passes à la ligne suivante. C'est super utile pour voir en direct ce que fait la ligne. (je manque de temps pour revenir commenter tout ceci)

21Formatic · Answer

Oups, j'ai oublié que pour ça, j'ai supprimé ta ligne 3, qui posait problème. Ça ne doit pas donner grand chose sur ton fichier, si ?

J'ai édité le code du précédent post, et voici avec le fichier sans la ligne 3.

18copie-de-exemple-a-3-zones.xlsm (28.81 Ko)

LouReeD · Answer

Pour éviter la sélection il faut attribuer la création à une variable Objet : Dim Sh As object Puis lors du Add pour le shape : Set Sh = ActiveSheet.Shape.Add(forme et dimension) Puis With Sh .Name = nom Etc... @ bientôt LouReeD...

LouReeD · Answer

A savoir les deux valeurs du Add après le type de forme correspondent au Left et au Top de la forme, comme cela la forme est directement positionnée au bon endroit lors de sa création si vous mettez les valeurs des deux dernières ligne du code de JoyeuxNoel. Les deux valeurs suivantes sont la largeur et la hauteur. @ bientôt LouReeD...

21Formatic · Answer

Bon sang, je l'ai fait il n'y a même pas 6 mois et j'ai déjà zappé 😕 Je n'arrive vraiment pas à me retrouver dans tous les codes déjà faits, et j'ai souvent la flemme d'aller vérifier toutes les propriétés... Ça donne ensuite ces approximations.....

LouReeD · Answer

Maintenant derrière mon ordi, voici ma proposition : Sub LouReeD() Dim Sh As Shape 'Boucle sur les formes de la feuille active For Each Sh In Feuil1.Shapes 'Vérifie si le nom de la forme commence par "Rectangle". If Sh.Name Like "Rectangle" & "*" Then Sh.Delete Next 'boucle sur toutes les cellules qui contiennent des noms d'entreprise For Each Cell In Range("N4:N" & Feuil1.Range("N" & Rows.Count).End(xlUp).Row) 'on créé un rectangle et on lui donne le nom Set Sh = ActiveSheet.Shapes.AddShape(msoShapeRectangle, Range("S1").Left, Cell.Offset(, 5).Top, _ Cell.Offset(, 5).Width, Cell.Offset(, 5).Height) With Sh .Name = "Rectangle" & Cell.Row - 2 .Fill.ForeColor.RGB = RGB(255, 255, 255) With .TextFrame2 .TextRange.Characters.Text = Cell.Value & Chr(13) & Cell.Offset(, 1).Value .TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0) End With .TextFrame.HorizontalAlignment = xlCenter .TextFrame.VerticalAlignment = xlCenter .TextFrame.AutoSize = True .Left = Range("S1").Left + 5 End With Next End Sub @ bientôt LouReeD...