XL 2019 Comment créer en VBA des Shapes groupés?

[njm504]

Bonjour à tous,
je cherche depuis un moment comment réaliser des shapes groupées par exemple 3 rectangles qui sont groupés lorsque la macro a terminé son exécution.

Par avance merci pour votre aide.

 

[Staple1600]

Bonsoir


A utiliser avec précaution

Sub Grouper()
Set Shp = ActiveSheet.DrawingObjects.group
Shp.Name = "toto"
End Sub

 

[Staple1600]

Re

Une version plus aboutie
(qui ne groupera que les rectangles de la feuille active)

Sub test_ok()
Dim tab_SHP() As Variant, i&, shp As Shape
With ActiveSheet
    ReDim tab_SHP(1 To .Shapes.Count)
        For i = 1 To .Shapes.Count
            If .Shapes(i).AutoShapeType = 1 Then ' 1=Rectangle
            tab_SHP(i) = .Shapes(i).Name
            End If
        Next
    Set shp = .Shapes.Range(tab_SHP).Group
End With
shp.Name = "TEST"
End Sub

 

[njm504]

Bonsoir Staple1600,

merci beaucoup pour ces retours rapides.

Je vais tester cela.

En fait, pour donner un peu plus d'explication, je vais introduire ces codes dans une boucle qui crée des rectangles en fonction de variable.
Pour l'exemple cela me servira à créer un plan.
Mon code dessine des rectangles alignés qui représentent des travées et l'ensemble de ces travées formera une rangée. Ces rangées sont alignées les une sous les autres.
Et donc, l'objectif c'est que les rangées composées de travées soient groupées pour pouvoir les positionner comme bon me semble et reproduire le plan d'un rayonnage.

Je ne sais pas si c'est très clair... je vais tester ce que vous me proposez, je pense adapter le second code car le premier semble risqué et vous faire un retour.

Merci encore.

 

[Staple1600]

Re

Le premier code possède un avertissement de couleur rouge, non ?


Le seul risque c'est d'avoir beaucoup de choses dans le Groupe

Le seconde lui est rectangulophile donc, là on sait à quoi s'en tenir.

 

[patricktoulon]

Bonjour à tous

Mon code dessine des rectangles alignés qui représentent des travées et l'ensemble de ces travées formera une rangée. Ces rangées sont alignées les une sous les autres.
Et donc, l'objectif c'est que les rangées composées de travées soient groupées pour pouvoir les positionner comme bon me semble et reproduire le plan d'un rayonnage.

si je ne me trompe pas ca s'appelle un organigrame

 

[njm504]

Bonjour à tous

si je ne me trompe pas ca s'appelle un organigrame

Bonjour, oui c'est vrai que décrit comme je l'ai fait on peut penser à un organigramme mais non en fait c'est réellement des rayonnages tels que l'on peut les voir chez IKEA par exemple.

 

[TooFatBoy]

en fait c'est réellement des rayonnages tels que l'on peut les voir chez IKEA par exemple.

Ah bon ? Moi, en te lisant, j'avais pensé à des rayonnages de supermarché, ou à ceux d'un hangar de stockage.


N'oublie pas de clore ton fil. Pour cela, coche la réponse #2 ou #3 selon celle qui a le mieux résolu ton problème.

 

[njm504]

Bonjour à tous,

Staple1600, les 2 codes que tu m'as proposés me posent des soucis.

Le premier ne possède pas de couleur rouge mais inclus dans ma boucle qui crée des rectangles génère l'erreur suivante: "Impossible de lire la propriété Group de la case DrawingObjects"

Le second, j'ai essayé de l'adapter mais j'ai une erreur: "L'objet PlagesForms doit contenir au moins deux éléments." et si c'est le nombre de rectangle il y en a bien plus que 2.

Maintenant seuls les deux codes fonctionnent parfaitement!

Voici mon code (attention je suis débutant!), tu y trouveras ton code n°2.

Sub MiseEnformerack_Plan_G()
ThisWorkbook.RefreshAll
'On dessine un carré pour une travée par rangée
    'variable
       Dim sh As Shape
       Dim i As Integer, NbRangee As Integer, nbtravee As Integer, Coorx As Integer, Coory As Integer
      Dim n As Integer
       n = 0
       NbRangee = Feuil6.Range("C2").Value 'nb de rangée
    'Zone de traçage
        ThisWorkbook.Worksheets("Plan_G").Activate
    ' Pas de grille de fond
        ActiveWindow.DisplayGridlines = False
    ' On vide l'existant
        ' À vider
        For i = ActiveSheet.Shapes().Count To 1 Step -1
        ActiveSheet.Shapes(i).Delete
        Next i
       ' Valeurs de départ
        Coorx = 300
        Coory = 20
       
        For nbligne = 1 To NbRangee
        ligne = nbligne + 1
        nbtravee = Cells(ligne, 2).Value
        n = n + 1

        For t = 1 To nbtravee
        Set sh = ActiveSheet.Shapes(). _
        AddShape(msoShapeRectangle, Coorx, Coory, 32, 10)

     ' Mise en forme
        sh.Line.Weight = 1.5
        sh.Line.ForeColor.RGB = RGB(30, 144, 255)
        sh.Fill.ForeColor.RGB = RGB(255, 255, 255)
        sh.Name = Cells(ligne, 1) & t

        With sh.TextFrame.Characters
        .Font.Color = vbBlack
        .Font.Size = 7
        .Text = Cells(ligne, 1) & t
        End With
    'Alignement du texte dans les case
    'Sélection de la rangée

        For Each s In ActiveSheet.Shapes
        If Not Intersect(s.TopLeftCell, Range("$D$1:$AD$40")) Is Nothing Then
        s.Select False
        End If
        Next s
    'Centrage du texte dans les cases
        Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
        Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
        msoAlignCenter
    ' Grouper les Shapes par rangée
        Dim tab_SHP() As Variant, v&, shp As Shape
        With ActiveSheet
         ReDim tab_SHP(1 To .Shapes.Count)
         For v = 1 To .Shapes.Count
            If .Shapes(v).AutoShapeType = 1 Then ' 1=Rectangle
            tab_SHP(v) = .Shapes(v).Name
            End If
         Next

        Set shp = .Shapes.Range(tab_SHP).Group
        End With
        shp.Name = "Rangee" & n
    ' Position suivante
        Coorx = Coorx + 32
        If t = nbtravee Then
        Coorx = 300
        Coory = Coory + 15
        End If

        Next t
        Next nbligne

Range("A2").Select
MsgBox "Le plan général a été crée !"
End Sub

 

[njm504]

Ah bon ? Moi, en te lisant, j'avais pensé à des rayonnages de supermarché, ou à ceux d'un hangar de stockage.


N'oublie pas de clore ton fil. Pour cela, coche la réponse #2 ou #3 selon celle qui a le mieux résolu ton problème.

mais c'est exactement cela!

 

[Staple1600]

Bonsoir @njm504

Donc j'en déduis que mon code du message#3 fait l'affaire ?

@TooFatBoy
Merci pour la synergie

 

[njm504]

Bonsoir @njm504

Donc j'en déduis que mon code du message#3 fait l'affaire ?

@TooFatBoy
Merci pour la synergie

Bonjour Staple 1600,

tu es très énigmatique et hélas ma réponse est non.
j'ai placé mon code dans ma réponse à ton message #3.
C'est surement plus simple pour comprendre.

Oui j'ajoute que la difficulté n'est pas d'avoir un groupe mais un groupe par rangée.

Encore merci pour ton aide.

 

[Staple1600]

Re

@njm504 504
Ceci est est bien le code que j'ai posté dans le message#3, non ?

Dim tab_SHP() As Variant, v&, shp As Shape
With ActiveSheet
ReDim tab_SHP(1 To .Shapes.Count)
For v = 1 To .Shapes.Count
If .Shapes(v).AutoShapeType = 1 Then ' 1=Rectangle
tab_SHP(v) = .Shapes(v).Name
End If
Next
Set shp = .Shapes.Range(tab_SHP).Group
End With

Donc ce que voulait dire TooFatBoy c'est que tu pouvais marqué ce message comme solution à ta question
(ou source d'inspiration si tu préfères)

Suis-je plus clair ?

 

[njm504]

Re

@njm504 504
Ceci est est bien le code que j'ai posté dans le message#3, non ?

Dim tab_SHP() As Variant, v&, shp As Shape
With ActiveSheet
ReDim tab_SHP(1 To .Shapes.Count)
For v = 1 To .Shapes.Count
If .Shapes(v).AutoShapeType = 1 Then ' 1=Rectangle
tab_SHP(v) = .Shapes(v).Name
End If
Next
Set shp = .Shapes.Range(tab_SHP).Group
End With

Donc ce que voulait dire TooFatBoy c'est que tu pouvais marqué ce message comme solution à ta question
(ou source d'inspiration si tu préfères)

Suis-je plus clair ?

Bonjour tu es très clair mais je me permet de reposter ma réponse à ton message #3:

Bonjour à tous,

Staple1600, les 2 codes que tu m'as proposés me posent des soucis.

Le premier ne possède pas de couleur rouge mais inclus dans ma boucle qui crée des rectangles génère l'erreur suivante: "Impossible de lire la propriété Group de la case DrawingObjects"

Le second, j'ai essayé de l'adapter mais j'ai une erreur: "L'objet PlagesForms doit contenir au moins deux éléments." et si c'est le nombre de rectangle il y en a bien plus que 2.

Maintenant seuls les deux codes fonctionnent parfaitement!

Voici mon code (attention je suis débutant!), tu y trouveras ton code n°2.

Sub MiseEnformerack_Plan_G()
ThisWorkbook.RefreshAll
'On dessine un carré pour une travée par rangée
'variable
Dim sh As Shape
Dim i As Integer, NbRangee As Integer, nbtravee As Integer, Coorx As Integer, Coory As Integer
Dim n As Integer
n = 0
NbRangee = Feuil6.Range("C2").Value 'nb de rangée
'Zone de traçage
ThisWorkbook.Worksheets("Plan_G").Activate
' Pas de grille de fond
ActiveWindow.DisplayGridlines = False
' On vide l'existant
' À vider
For i = ActiveSheet.Shapes().Count To 1 Step -1
ActiveSheet.Shapes(i).Delete
Next i
' Valeurs de départ
Coorx = 300
Coory = 20

For nbligne = 1 To NbRangee
ligne = nbligne + 1
nbtravee = Cells(ligne, 2).Value
n = n + 1

For t = 1 To nbtravee
Set sh = ActiveSheet.Shapes(). _
AddShape(msoShapeRectangle, Coorx, Coory, 32, 10)

' Mise en forme
sh.Line.Weight = 1.5
sh.Line.ForeColor.RGB = RGB(30, 144, 255)
sh.Fill.ForeColor.RGB = RGB(255, 255, 255)
sh.Name = Cells(ligne, 1) & t

With sh.TextFrame.Characters
.Font.Color = vbBlack
.Font.Size = 7
.Text = Cells(ligne, 1) & t
End With
'Alignement du texte dans les case
'Sélection de la rangée

For Each s In ActiveSheet.Shapes
If Not Intersect(s.TopLeftCell, Range("$D$1:$AD$40")) Is Nothing Then
s.Select False
End If
Next s
'Centrage du texte dans les cases
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
msoAlignCenter
' Grouper les Shapes par rangée
Dim tab_SHP() As Variant, v&, shp As Shape
With ActiveSheet
ReDim tab_SHP(1 To .Shapes.Count)
For v = 1 To .Shapes.Count
If .Shapes(v).AutoShapeType = 1 Then ' 1=Rectangle
tab_SHP(v) = .Shapes(v).Name
End If
Next

Set shp = .Shapes.Range(tab_SHP).Group
End With
shp.Name = "Rangee" & n
' Position suivante
Coorx = Coorx + 32
If t = nbtravee Then
Coorx = 300
Coory = Coory + 15
End If

Next t
Next nbligne

Range("A2").Select
MsgBox "Le plan général a été crée !"
End Sub

Donc je ne peux pas mettre terminé, ce la ne fonctionne pas!

 

[Staple1600]

Re

@njm504
Tu te rends compte que tu écris ceci

Staple1600, les 2 codes que tu m'as proposés me posent des soucis.

alors que depuis le début de la discussion, tu n'as pas joint de fichier exemple sur lequel tester nos propositions...

Mes deux propositions n'ont pu être testé sur cette seule base : le message#1
Dans lequel on ne parle par le couleur rouge.

Conseil en passant
Utilises les balises CODE quand publie du code VBA
(Ci-dessous non pas une solution, mais une simplification syntaxique pour une partie du code)

Sub MiseEnformerack_Plan_G_test()
Dim sh As Shape
Dim r, NbRangee&, nbtravee&, Coorx&, Coory&, n&
n = 0
NbRangee = 16 ' pour test
''Zone de traçage
Coorx = 300
Coory = 20
For nbligne = 1 To NbRangee 'juste pour test
ligne = nbligne + 1
nbtravee = Cells(ligne, 2).Value
n = n + 1
For t = 1 To nbtravee
    With ActiveSheet.Shapes().AddShape(msoShapeRectangle, Coorx, Coory, 32, 10)
        nom = Cells(ligne, 1) & t
        .Line.Weight = 1.5
        .Line.ForeColor.RGB = RGB(30, 144, 255)
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .Name = nom
            With .TextFrame.Characters
                .Font.Size = 7: .Font.Color = vbBlack: .Text = nom
            End With
        .TextFrame2.VerticalAnchor = msoAnchorMiddle
        .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    End With
' Position suivante
Coorx = Coorx + 32
If t = nbtravee Then
Coorx = 300
Coory = Coory + 15
End If
Next t
Next nbligne
MsgBox "Le plan général a été crée !"
End Sub