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

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
N

njm504

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

njm504

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

Staple1600

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

njm504

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

  • Plan avec couleur.xlsm
    26.3 KB · Affichages: 4
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bah j'avais cru comprendre qu'il fallait colorer les rangées.

Pour colorer les Shapes une par une :
VB: 
If IsNumeric(Application.Match(s.Name, couleur, 0)) Then s.Fill.ForeColor.RGB = vbRed
 

Pièces jointes

  • Test plan(4).xlsm
    136.2 KB · Affichages: 10
Vote positif 0 Vote négatif
N

njm504

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

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

16 membres et 304 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