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

La proposition de job75 (merci) m'a permis d'alléger mon code
Test OK sur le fichier Test_plan3
NB: Comme dit précédemment, je supprime manuellement les objets de la feuille.
(touche F5)
VB: 
Sub MiseEnforme_Rack_Plan_G_CINQUO()
Dim s As Shape, Shp As Shape, i&, arrSh(100)
Set F = ActiveSheet: X = 300: Y = 20: L = 32: h = 10
'création et mise en forme du rectangle "modéle"
MEF_Shape F.Shapes.AddShape(1, 300, 20, 32, 10), "modele", vbRed, 189354
For i = 2 To F.Cells(Rows.Count, 1).End(xlUp).Row
    rack = F.Cells(i, 1)
        For j = 1 To Val(F.Cells(i, 2))
        Set s = F.Shapes("modele").Duplicate
        s.Left = X + L * (j - 1): s.Top = Y + (15 * (i - 2))
        s.TextFrame.Characters.Text = rack & j: s.Name = rack & j
        k = k + 1: arrSh(k) = s.Name
        Next j
    If j > 2 Then
    F.Shapes.Range(arrSh).Group.Name = "Rangée_" & rack: Erase arrSh
    End If
    Next i
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
 
Vote positif 0 Vote négatif
Re
j'ai enfin pu tester le fameux code CINQUO et merveille, c'est fabuleux! un condensé !

Alors pour information, rien à faire pour lancer la macro, le message d'erreur persistait même si tout était vide après appuis sur F5. J'ai dû ajouter encore une fois dans le code la vidange pour que le reste passe:

VB: 
' On vide l'existant
        For v = ActiveSheet.Shapes().Count To 1 Step -1
            ActiveSheet.Shapes(v).Delete
        Next v

Aller comprendre pourquoi!?

En tout cas super mixe avec job75! merci à vous

pour aller plus loin:
La suite, c'est ajouté des variables pour que mes travées puissent avoir une longueur différente dans mes rangées et une couleur différentes à certaines grâce aux coordonnées: ex C3 en rouge!
Pour la première partie je vais utiliser je pense des modèles de Shapes et le travail de job75 et pour la seconde partie je vais regarder en profondeur comment tu as mis de la couleur et comment surtout isoler et coloriser certaines travées uniquement.

Voilà.
 
Vote positif 0 Vote négatif
Re
Je veux bien encore un petit coup de main !

Alors comme évoqué, le but cette fois-ci est de colorier en rouge le Shape d'une travée indiquée dans un tableau.

Ma question c'est comment comparer les noms des shapes qui sont bien identifiés par travée dans les rangés exemples: B2 et la comparer à la liste des travées à colorié situé dans un autre onglet.

J'ai étudié pas mal de possibilité mais trop lourdes et complexes en comparaison à ce que vous avez pu réaliser.

Ci-joint le fichier.

Par avance merci.
 
Vote positif 0 Vote négatif
Re

En attendant le fichier (et parce que l'aprés-midi est ici pluvieux et venteux)
Je me suis occupé dans mon VBA
J'attends tes questions et commentaires. 😉
PS: Code à vocation purement illustrative
(on en fera l'usage que l'on veut ou pas)
Code: 
Sub MiseEnforme_Rack_Plan_G_SIXTO()
Dim s As Shape, Shp As Shape, i&, arrSh(100), col
raz
Set F = ActiveSheet: X = 300: Y = 20: L = 32: H = 10
col = Array(11851260, vbMagenta, 12566463, vbBlue, vbGreen, vbYellow, 9944516) 'tableau des couleurs
For i = 2 To F.Cells(Rows.Count, 1).End(xlUp).Row
    rack = F.Cells(i, 1)
        For j = 1 To Val(F.Cells(i, 2))
        xCol = CLng(col(i - 2))
        Set s = Forme(msoShapeRectangle, 300, 20, , , , xCol)
        s.Left = X + L * (j - 1): s.Top = Y + (15 * (i - 2))
        s.TextFrame.Characters.Text = rack & j: s.Name = rack & j
        k = k + 1: arrSh(k) = s.Name
        Next j
    If j > 2 Then
    F.Shapes.Range(arrSh).Group.Name = "Rangée_" & rack: Erase arrSh
    End If
    Next i
End Sub
Function Forme(atSh As MsoAutoShapeType, X, Y, Optional H = 32, Optional L = 10, Optional cLi = vbBlue, Optional cFi = vbWhite) As Shape
Set Forme = ActiveSheet.Shapes.AddShape(atSh, X, Y, H, L)
Forme.Line.Weight = 1.5: Forme.Line.ForeColor.RGB = cLi: Forme.Fill.ForeColor.RGB = cFi
Forme.TextFrame.Characters.Font.Size = 7: Forme.TextFrame.Characters.Font.Color = vbBlack
Forme.TextFrame2.VerticalAnchor = 3: Forme.TextFrame2.TextRange.ParagraphFormat.Alignment = 2
End Function
Sub raz()
Dim v& 'On vide l'existant
For v = ActiveSheet.Shapes.Count To 1 Step -1
ActiveSheet.Shapes(v).Delete
Next v
End Sub
 
Vote positif 0 Vote négatif
Staple1600 à dit:
Re

En attendant le fichier (et parce que l'aprés-midi est ici pluvieux et venteux)
Je me suis occupé dans mon VBA
J'attends tes questions et commentaires. 😉
PS: Code à vocation purement illustrative
(on en fera l'usage que l'on veut ou pas)
Code: 
Sub MiseEnforme_Rack_Plan_G_SIXTO()
Dim s As Shape, Shp As Shape, i&, arrSh(100), col
raz
Set F = ActiveSheet: X = 300: Y = 20: L = 32: H = 10
col = Array(11851260, vbMagenta, 12566463, vbBlue, vbGreen, vbYellow, 9944516) 'tableau des couleurs
For i = 2 To F.Cells(Rows.Count, 1).End(xlUp).Row
    rack = F.Cells(i, 1)
        For j = 1 To Val(F.Cells(i, 2))
        xCol = CLng(col(i - 2))
        Set s = Forme(msoShapeRectangle, 300, 20, , , , xCol)
        s.Left = X + L * (j - 1): s.Top = Y + (15 * (i - 2))
        s.TextFrame.Characters.Text = rack & j: s.Name = rack & j
        k = k + 1: arrSh(k) = s.Name
        Next j
    If j > 2 Then
    F.Shapes.Range(arrSh).Group.Name = "Rangée_" & rack: Erase arrSh
    End If
    Next i
End Sub
Function Forme(atSh As MsoAutoShapeType, X, Y, Optional H = 32, Optional L = 10, Optional cLi = vbBlue, Optional cFi = vbWhite) As Shape
Set Forme = ActiveSheet.Shapes.AddShape(atSh, X, Y, H, L)
Forme.Line.Weight = 1.5: Forme.Line.ForeColor.RGB = cLi: Forme.Fill.ForeColor.RGB = cFi
Forme.TextFrame.Characters.Font.Size = 7: Forme.TextFrame.Characters.Font.Color = vbBlack
Forme.TextFrame2.VerticalAnchor = 3: Forme.TextFrame2.TextRange.ParagraphFormat.Alignment = 2
End Function
Sub raz()
Dim v& 'On vide l'existant
For v = ActiveSheet.Shapes.Count To 1 Step -1
ActiveSheet.Shapes(v).Delete
Next v
End Sub
Cliquez pour agrandir...

c'est vrai qu'aujourd'hui le temps est à faire du vba!

je suis trop nul, je pensais avoir joint le fichier, cette fois-ci tu le trouveras.

après que dire à part merci, merci et merci pour ton travail et talent.

Je regarde la macro.
 

Pièces jointes

Vote positif 0 Vote négatif
job75 à dit:
Bah j'avais cru comprendre qu'il fallait colorer les rangées.

öur xolorer les Sh
Cliquez pour agrandir...
Pas de soucis, c'est moi qui n'avais pas inséré le fichier.

En faite avec le code QUINTO de Staple 1600 les rangées sont bien nommées et j'ai constaté également que les travées l'étaient aussi dans chaque rangée.

Donc ton code fonctionne très bien pour colorer une rangée mais si dans la colonne de A de l'onglet "Rangées à colorer" on pouvait y retrouver B4 par exemple, c'est uniquement le shape nommé B4 qui passerait en rouge.

Ton code est super précis. Merci beaucoup. Il m'aide à comprendre.
 
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
907
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
241
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