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

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion njm504
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
N

njm504

XLDnaute Nouveau
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.
 
Solution
Staple1600
Re

Une version plus aboutie
(qui ne groupera que les rectangles de la feuille active)
Code: 
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
Trier par date Trier par votes
Re

Une version plus aboutie
(qui ne groupera que les rectangles de la feuille active)
Code: 
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
 
Vote positif 0 Vote négatif
Solution
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.
 
Vote positif 0 Vote négatif
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.
Cliquez pour agrandir...
si je ne me trompe pas ca s'appelle un organigrame
 
Vote positif 0 Vote négatif
njm504 à dit:
en fait c'est réellement des rayonnages tels que l'on peut les voir chez IKEA par exemple.
Cliquez pour agrandir...
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.👍
 
Dernière édition:
Vote positif 0 Vote négatif
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.

VB: 
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
 
Dernière édition:
Vote positif 0 Vote négatif
Staple1600 à dit:
Bonsoir @njm504

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

@TooFatBoy
Merci pour la synergie 😉
Cliquez pour agrandir...
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.
 
Vote positif 0 Vote négatif
Re

@njm504 504
Ceci est est bien le code que j'ai posté dans le message#3, non ?
VB: 
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 ?
 
Vote positif 0 Vote négatif
Staple1600 à dit:
Re

@njm504 504
Ceci est est bien le code que j'ai posté dans le message#3, non ?
VB: 
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 ?
Cliquez pour agrandir...
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
Cliquez pour agrandir...

Donc je ne peux pas mettre terminé, ce la ne fonctionne pas!
 
Dernière édition:
Vote positif 0 Vote négatif
Re

@njm504
Tu te rends compte que tu écris ceci
Staple1600, les 2 codes que tu m'as proposés me posent des soucis.
Cliquez pour agrandir...

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)
VB: 
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
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

P
  • Résolu(e)
Microsoft 365 Afficher / masquer des shapes ou des groupes de shapes avec condition mini/maxi
2
Réponses
27
Affichages
908
pat66
P
Y
  • Question Question
XL 2016 Création d'un publipostage avec PJ PDF sur Outlook
Réponses
2
Affichages
174
Phil69970
Phil69970
Y
  • Question Question
Microsoft 365 VBA - Basculer des lignes d'onglet en onglet selon un critère
2
Réponses
18
Affichages
752
yanus
Y
D
  • Question Question
XL 2019 Suppression doublons combinés entre deux cellules associées et présentation sous forme de tableau
Réponses
13
Affichages
201
alexga78
A
M
  • Question Question
Microsoft 365 Créer en VBA un Fichier Xml a partir d'un tableau
2
Réponses
15
Affichages
300
patricktoulon
patricktoulon
R
  • Question Question
Microsoft 365 Formule Outlook,
Réponses
8
Affichages
113
fanch55
fanch55
murainesouspatate
  • Question Question
XL 2021 Alimenter une ComboBox dans l'ordre décroissant
2
Réponses
15
Affichages
233
murainesouspatate
murainesouspatate
P
  • Résolu(e)
Microsoft 365 Macro qui permet d'afficher ou pas des Shapes
Réponses
12
Affichages
919
pat66
P
C
  • Question Question
Microsoft 365 Créer un synthèse de plusieurs onglets
Réponses
7
Affichages
471
cdric78
C
L
  • Résolu(e)
XL 2021 de formulaire...
2
Réponses
15
Affichages
1 K
TooFatBoy
TooFatBoy
J
  • Question Question
XL 2016 Code VBA pour éclater un fichier en x fichier par mois
2 3
Réponses
36
Affichages
196
vgendron
vgendron
F
  • Résolu(e)
XL 2019 VBA : revenir à la feuille précédente ActiveSheet.Previous.Select
Réponses
14
Affichages
222
Fabien.Romo
F
R
  • Question Question
XL 2019 Colorer des shapes en récupérant la couleur d'une cellule
2
Réponses
16
Affichages
1 K
ruliann
R
A
  • Question Question
XL 2013 Renvoie le jour en dehors des week ends et jours fériés
Réponses
5
Affichages
208
abouam
A
R
  • Question Question
Microsoft 365 Fichier partagé via one drive M365
Réponses
1
Affichages
47
wDog66
wDog66
Z
  • Résolu(e)
Microsoft 365 Mise en forme de QRCodes dans un model
Réponses
6
Affichages
246
Zaadox
Z
I
  • Question Question
XL 2021 VBA - importer des tableaux dans un fichier excel
2 3
Réponses
35
Affichages
429
imadaddy
I
S
  • Résolu(e)
Microsoft 365 vba enregistrer sous en enlevant la lecture seule
Réponses
4
Affichages
454
Scrabblouille
S
T
  • Question Question
XL 2016 VBA listing de contacts
Réponses
1
Affichages
346
Dranreb
Dranreb
J
  • Résolu(e)
XL 2013 Créer une macro avec un fichier pour envoyer par mail
Réponses
7
Affichages
371
TooFatBoy
TooFatBoy
Retour