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

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
Staple1600

Staple1600

XLDnaute Barbatruc
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
N

njm504

XLDnaute Nouveau
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
patricktoulon

patricktoulon

XLDnaute Barbatruc
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
N

njm504

XLDnaute Nouveau
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
N

njm504

XLDnaute Nouveau
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
Staple1600

Staple1600

XLDnaute Barbatruc
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
N

njm504

XLDnaute Nouveau
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
Staple1600

Staple1600

XLDnaute Barbatruc
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... :rolleyes:

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

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
802
pat66
P
P
  • Résolu(e)
Microsoft 365 Macro qui permet d'afficher ou pas des Shapes
Réponses
12
Affichages
841
pat66
P
L
  • Résolu(e)
XL 2021 de formulaire...
2
Réponses
15
Affichages
974
TooFatBoy
TooFatBoy
Y
  • Question
Microsoft 365 VBA - Basculer des lignes d'onglet en onglet selon un critère
2
Réponses
18
Affichages
601
yanus
Y
T
  • Résolu(e)
XL 2021 Liste déroulante conditionnée
Réponses
6
Affichages
177
Gégé-45550
Gégé-45550
R
  • Question
XL 2019 Colorer des shapes en récupérant la couleur d'une cellule
2
Réponses
16
Affichages
1 K
ruliann
R
C
  • Question
Microsoft 365 Créer un synthèse de plusieurs onglets
Réponses
7
Affichages
291
cdric78
C
F
  • Question
Microsoft 365 Créer un plan interactif a partir d'un tableau
Réponses
1
Affichages
75
Fitzdal
F
A
  • Question
XL 2013 Renvoie le jour en dehors des week ends et jours fériés
Réponses
5
Affichages
116
abouam
A
N
  • Question
Microsoft 365 Séparer NOM et Prénom d'une ListBox dans 2 Textbox
5 6 7
Réponses
100
Affichages
2 K
NONO14
N

Membres actuellement en ligne

20 membres et 326 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 487
Messages
2 110 121
Membres
110 677
dernier inscrit
volare