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.

 

[njm504]

Re

je suis vraiment désolé si j'ai pu être maladroit, je m'en excuse réellement. Ce n'est pas du tout mon intention de contrarier.

C'est mes premiers posts et je ne suis pas à l'aise comme tu as pu le remarquer. C'est vrai qu'avec mon message initial tu as répondu et donné la solution (que j'ai mentionnée) immédiatement.

Je n'ai donc pas été clair mais avec ces nouveaux éléments je vais essayer à nouveau car ma boucle initiale n'était pas propre au regard de la tienne. Maintenant j'ai les bases pour trouver la solution.

Encore un énorme merci, c'est vraiment bluffant la rapidité avec laquelle tu réponds et apportes des solutions. C'est là le truc, sache que moi je buche des heures parfois pour en arriver là!

donc merci beaucoup.

 

[Staple1600]

Re

@njm504
Je ne suis pas froissé, ni contrarié.

Le premier conseil qu'on donne aux petits nouveaux, c'est de prendre le temps de construire un fichier exemple (*) et de poster dans le 1er message de la discussion.

J'essaie donc simplement de te faire découvrir les us et coutumes du forum.

(*) Cela constitue une base pour ceux qui veulent répondre à la question

Ici pour ta question, on ne connait le contenu des colonnes A et B
ni le résultat final à obtenir.

 

[njm504]

ok c'est noté.

Donc ci-joint le fichier de test épuré pour la question.

J'ai remis le code à jour comme tu me l'as conseillé en ajoutant un nettoyage des shapes au démarrage si non le code pour grouper ne fonctionnes pas (erreur indiquée dans mes précédents posts).

Fonctionnement:
On renseigne manuellement les colonnes A (nom de la rangée) et B (nombre de travées de la rangée) et en C le nombre de rangée totale.

On lance la macro et le plan va se former.

J'y suis presque, maintenant c'est groupé mais ce n'est pas ce que je veux. Le but est de déplacer les rangées et de les orienter de la manière que l'on veut mais rangée par ranger afin de réaliser un plan qui se conforme à la réalité. Donc, lorsque la macro se termine c'est la première rangée qui doit être groupée puis la seconde etc...

Je pense que c'est plus simple de comprendre avec le fichier.

 

[Staple1600]

Re

En ré-agencant le code de la sorte, je n'ai pas de message d'erreur.
Ici c'est toujours toutes les formes qui constituent le groupe
La suite après mon souper/diner

Sub MiseEnformerack_Plan_G()
    'variable
        Dim sh As Shape, r, NbRangee&, nbtravee&, Coorx&, Coory&, n&, ligne&
        Dim tab_SHP() As Variant, v&, shp As Shape
        n = 0
        NbRangee = Feuil6.Range("C2").Value 'nb derangée
    ' On vide l'existant
        For i = ActiveSheet.Shapes().Count To 1 Step -1
            ActiveSheet.Shapes(i).Delete
        Next i
    ' Valeurs de départ
        Coorx = 300: Coory = 20
    'Boucle des rangées
        For nbligne = 1 To NbRangee
            ligne = nbligne + 1
            nbtravee = Cells(ligne, 2).Value
            n = n + 1
    'Boucle des travées
            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
        ' Grouper les Shapes par rangée
        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 v
            ActiveSheet.Shapes.Range(tab_SHP).Group.Name = "PLAN_G"
        End With
MsgBox "Le plan général a été crée !"
End Sub

 

[Staple1600]

Re

Pendant que la gratiin dore dans le four;

Est-ce qu'on se rapproche du résultat souhaité ?

Sub MiseEnformerack_Plan_G_B()
    'variable
        Dim sh As Shape, r, NbRangee&, nbtravee&, Coorx&, Coory&, n&, ligne&, arrSh()
        Dim tab_SHP() As Variant, v&, shp As Shape
        n = 0
        NbRangee = Feuil6.Range("C2").Value 'nb derangée
    ' On vide l'existant
        For i = ActiveSheet.Shapes().Count To 1 Step -1
            ActiveSheet.Shapes(i).Delete
        Next i
    ' Valeurs de départ
        Coorx = 300: Coory = 20
    'Boucle des rangées
        For nbligne = 1 To NbRangee
            ligne = nbligne + 1
            nbtravee = Cells(ligne, 2).Value
            n = n + 1
    'Boucle des travées
    ReDim arrSh(nbtravee)
            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
                   arrSh(t) = .Name
                    
                End With
                ' Position suivante
                Coorx = Coorx + 32
                If t = nbtravee Then
                ActiveSheet.Shapes.Range(arrSh).Group.Name = "Rangée_" & Cells(ligne, 1).Value
                Erase arrSh
                Coorx = 300
                Coory = Coory + 15
                End If
            Next t
        Next nbligne
MsgBox "Le plan général a été crée !"
End Sub

 

[njm504]

Je viens de tester et c'est exactement ce que je voulais!

C'est parfait, merci beaucoup.

Je vais pouvoir continuer à travailler mon projet sereinement.

Bravo!

 

[Staple1600]

Re

Pour ta prochaine question, penses à mettre un fichier exemple dès le départ.
C'est indolore
Et cela facilitera les tests pour ceux qui voudront d'aider.

Bonne continuation dans ton projet.

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

Quand on voit les userforms qu'il y a dans ton classeur, je n'appelle pas cela "débuter dans la carrière" en VBA

 

[Staple1600]

Bonjour @njm504

Pour le fun et pour varier les plaisirs
En utilisant la méthode Duplicate
Code brut de décoffrage
Testé sur ton fichier exemple.

Sub MiseEnforme_Rack_Plan_G_TER()
Dim s As Shape, Shp As Shape, i&, arrSh(100)
Set f = ActiveSheet: X = 300: Y = 20
With f.Shapes.AddShape(1, 300, 20, 32, 10) 'c'est le rectangle "modéle" avec définition des ses propriétés
With .TextFrame.Characters: .Font.Size = 7: .Font.Color = vbBlack: End With: .Name = "modele"
.Line.Weight = 1.5: .TextFrame2.VerticalAnchor = 3: .TextFrame2.TextRange.ParagraphFormat.Alignment = 2
.Line.ForeColor.RGB = RGB(30, 144, 255): .Fill.ForeColor.RGB = RGB(255, 255, 255)
End With
For i = 2 To f.Cells(Rows.Count, 1).End(xlUp).Row
    For j = 1 To Cells(i, 2).Value
        Set Shp = f.Shapes("modele").Duplicate 'duplication N fois du modéle
        With Shp
        nom = Cells(i, 1) & j: .Left = X + XX: .Top = Y + YY: .Name = nom
        .TextFrame.Characters.Text = nom: k = k + 1: arrSh(k) = .Name
        End With
    XX = XX + 32
    If j = Cells(i, 2).Value Then
    f.Shapes.Range(arrSh).Group.Name = "Rangée_" & Cells(i, 1).Value 'groupage des formes
    Erase arrSh: YY = (YY + 15)
    End If
    Next
Next
'un peu de ménage
f.Shapes("modele").Delete: For Each s In ActiveSheet.Shapes: s.Left = 300: Next
End Sub

 

[njm504]

Bonjour Staple 1600,

incroyable, dans cette version , le code est encore plus épuré et propre. Merci de prendre de ton temps pour ce cas. C'est vraiment super!
Alors, je viens de tester ce code sur le ficher et il indique une erreur "Le groupage est désactivé pour les formes sélectionnées" à la ligne de commande:

f.Shapes.Range(arrSh).Group.Name = "Rangée_" & Cells(i, 1).Value 'groupage des formes

C'est pourtant la même instruction de groupe que dans le code précédant... je regarde si je trouve.

J'ai vraiment hâte de tester.

 

[Staple1600]

Re

Je viens de tester à nouveau.
Pas de message d'erreur
Conditions du test
Aucune forme sur la feuille avant exécution de la macro
Voici le résultat obtenu
J'ai sélectionné le dernier groupe
On peut observer que le nom corresponds bien à ton souhait.

 

[job75]

Bonjour njm504, JM,

J'avais fait à peu près la même chose mais je groupe les Shapes par sélection multiple :

Sub Creer_Shapes()
Dim F As Worksheet, model As Shape, L, h, debx, deby, s, i&, lettre$, j%
Set F = Feuil6
Set model = F.Shapes("Modele")
L = model.Width
h = model.Height
debx = 300
deby = 20
Application.ScreenUpdating = False
'---RAZ---
For Each s In F.Shapes
    If s.Name Like "Groupe*" Then s.Delete
Next
'---duplication et groupage---
For i = 2 To F.[A1].CurrentRegion.Rows.Count
    lettre = F.Cells(i, 1)
    For j = 1 To Val(F.Cells(i, 2))
        Set s = model.Duplicate
        s.Left = debx + L * (j - 1)
        s.Top = deby + (h + 15) * (i - 2)
        s.TextFrame.Characters.Text = lettre & j
        s.Name = lettre & j
        s.Select False 'sélection multiple
    Next j
    If j > 2 Then
        Set s = Selection.Group
        s.Name = "Groupe " & lettre
        ActiveCell.Activate 'désélectionne
    End If
Next i
End Sub

Si l'on veut on peut masquer/démaquer la Shape modèle.

A+

 

[Staple1600]

Bonjour @job75

J'étais passé à l'étape suivante: choix des couleurs

Sub MiseEnforme_Rack_Plan_G_QUATRO()
Dim s As Shape, Shp As Shape, i&, arrSh(100)
Set f = ActiveSheet: X = 300: Y = 20
'création et mise en forme du rectangle "modéle"
MEF_Shape f.Shapes.AddShape(1, 300, 20, 32, 10), "modele"
For i = 2 To f.Cells(Rows.Count, 1).End(xlUp).Row
    For j = 1 To Cells(i, 2).Value
        Set Shp = f.Shapes("modele").Duplicate 'duplication N fois du modéle
        With Shp
        Nom = Cells(i, 1) & j: .Left = X + XX: .Top = Y + YY: .Name = Nom
        .TextFrame.Characters.Text = Nom: k = k + 1: arrSh(k) = .Name
        End With
    XX = XX + 32
    If j = Cells(i, 2).Value Then
    f.Shapes.Range(arrSh).Group.Name = "Rangée_" & Cells(i, 1).Value 'groupage des formes
    Erase arrSh: YY = (YY + 15)
    End If
    Next
Next
'un peu de ménage
f.Shapes("modele").Delete: For Each s In ActiveSheet.Shapes: s.Left = 300: Next
End Sub

Function MEF_Shape(s As Shape, Nom As String, Optional c_L As Long = vbBlue, Optional c_F As Long = vbWhite)
s.Name = Nom
With s.TextFrame.Characters.Font
.Size = 7: .Color = vbBlack
End With
s.TextFrame2.VerticalAnchor = 3: s.TextFrame2.TextRange.ParagraphFormat.Alignment = 2
s.Line.Weight = 1.5: s.Line.ForeColor.RGB = c_L: s.Fill.ForeColor.RGB = c_F
End Function

 

[job75]

Fichier (2) avec la Shape modèle masquée, j'utilise cette macro :

Sub Afficher_Masquer_Modele()
With Feuil6.Shapes("Modele")
    .Visible = Not .Visible
End With
End Sub

 

[Staple1600]

Re

Pour @njm504
La version 27 offre le choix des couleurs
=> Dans la macro: MiseEnforme_Rack_Plan_G_QUATRO
Remplacer cette ligne
MEF_Shape F.Shapes.AddShape(1, 300, 20, 32, 10), "modele"
par
MEF_Shape F.Shapes.AddShape(1, 300, 20, 32, 10), "modele", vbMagenta, vbGreen

A toi de voir si cela peut servir ton projet.

 

[njm504]

Pour @job75

Bonjour job75,

vraiment intéressant ton travail, il m'ouvre des possibilités tant qu'à la forme à adapter et l'insérer simplement, un grand merci pour ce partage.

Pour @Staple1600

Re,
Ton travail est toujours aussi impressionnant! Evidemment que cela va servir à mon projet tu es déjà à l'étape suivante!

Bon je t'avoue que je n'ai toujours pas solutionné mon erreur c'est bizarre. Mais je te joins le fichier avec toutes les macros proposées et tu me diras si pour tu observes le même constat.

Comme tu es très rapides, J'ajoute une difficulté supplémentaire. En faites la partie de gauche est simplifiée. Le tableau qui est rempli manuellement est issu initialement d'un tableau croisé dynamique et donc j'ai peur que les résultats de ce tableau n'aillent me poser des problèmes pour les variables. Je posterai bien sûr le fichier mais allons étape par étapes

Merci à vous pour votre aide, je suis maintenant moins seul et cela m'ouvre de nouvelles perspectives!