Génération de formes automatiques

**alphonsenet** · 02/12/2013, 22h17

Bonjour à toutes et à tous,
Tout d'abord, je tiens à préciser que je débute dans les macros Excel.
Mon problème est pourtant simple à comprendre :
je souhaiterai générer automatiquement une forme avec deux branches : OUI et NON.
La forme que je souhaite est sur une feuille, et je souhaite la générer plusieurs fois sur une autre feuille.
J'ai actuellement deux maccros qui le font (en premier faire décision puis OUI_NON).
Le problème c'est que je ne peux déplacer que la forme et les flèches, mais le texte ne suit pas..
Aussi, une fois la première forme générée et déplacée, lorsque j'en créé une nouvelle, ça bug.
Je pense que c'est du au référence qui sont statiques et non relatives, mais je ne sais pas vraiment comment m'en sortir.
Merci d'avance pour votre aide, vous trouverez ci-joint les feuilles de travail.
Voici le codes des deux macros (faite à partir d'enregistrements donc pas optimales) à exécuter l'une après l'autre :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Sub Decision()
'
' Test Macro
'
 
'
    Sheets("Formalisme").Select
    ActiveSheet.Shapes.Range(Array("AutoShape 2")).Select
    Selection.Copy
    Sheets("Feuil2").Activate
    Range("M6").Select
    ActiveSheet.Paste
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 844.5, 123.3750393701, _
        903.75, 123.75).Select
        Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadOpen
    Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes( _
        "AutoShape 2"), 4
    Selection.ShapeRange.ShapeStyle = msoLineStylePreset1
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 782.25, 171.75, 782.25, _
        216).Select
        Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadOpen
    Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes( _
        "AutoShape 2"), 3
    Selection.ShapeRange.ShapeStyle = msoLineStylePreset1
    ActiveSheet.Shapes.Range(Array("AutoShape 2")).Select
 
End Sub
Sub OUI_NON()
'
' OUI_NON Macro
'
 
'
    ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 847.5, 112.5, 30, 9 _
        ).Select
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "OUI"
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 3).ParagraphFormat. _
        FirstLineIndent = 0
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 3).Font
        .NameComplexScript = "+mn-cs"
        .NameFarEast = "+mn-ea"
        .Fill.Visible = msoTrue
        .Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
        .Fill.ForeColor.TintAndShade = 0
        .Fill.ForeColor.Brightness = 0
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = 11
        .Name = "+mn-lt"
    End With
    Selection.ShapeRange.ScaleHeight 2, msoFalse, msoScaleFromBottomRight
    Selection.ShapeRange.ScaleWidth 1.35, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.9583333333, msoFalse, _
        msoScaleFromBottomRight
    Selection.ShapeRange.Line.Visible = msoFalse
    ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 786, 183, 30.75, _
        16.5).Select
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "NON"
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 3).ParagraphFormat. _
        FirstLineIndent = 0
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 3).Font
        .NameComplexScript = "+mn-cs"
        .NameFarEast = "+mn-ea"
        .Fill.Visible = msoTrue
        .Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
        .Fill.ForeColor.TintAndShade = 0
        .Fill.ForeColor.Brightness = 0
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = 11
        .Name = "+mn-lt"
    End With
    Selection.ShapeRange.ScaleWidth 1.3170731707, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 1.1818181818, msoFalse, _
        msoScaleFromBottomRight
    Selection.ShapeRange.IncrementLeft -3.75
    Selection.ShapeRange.IncrementTop -3
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.ScaleWidth 0.8703703704, msoFalse, msoScaleFromBottomRight
    Selection.ShapeRange.ScaleHeight 0.9615384615, msoFalse, _
        msoScaleFromBottomRight
    Selection.ShapeRange.ScaleWidth 1.1276618082, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 1.1199958005, msoFalse, _
        msoScaleFromBottomRight
    Selection.ShapeRange.ScaleHeight 0.7499990626, msoFalse, _
        msoScaleFromBottomRight
    Selection.ShapeRange.IncrementLeft -4.5
    Selection.ShapeRange.IncrementTop -0.75
 
End Sub

Invité · 03/12/2013, 07h02

Bonjour,

Il vous faut grouper vos différentes formes sur la feuille Formalisme avant de dupliquer.

Dans le fichier joint, la forme regroupée dans la feuille Formalisme est appelée GroupeOuiNon. Elle contient les formes : AutoShape 2, Connecteur droit avec flèche 3, Connecteur droit avec flèche 4, Rectangle 14, Rectangle 21. La macro Decision, ci-dessous, duplique la forme groupe dans la feuille 2 et renomme la forme.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub Decision()
 
Dim CtrI As Long
 
    Sheets("Formalisme").Select
    ActiveSheet.Shapes.Range("GroupeOuiNon").Select
    Selection.Copy
    Sheets("Feuil2").Activate
    Range("M6").Select
    ActiveSheet.Paste
    For CtrI = 1 To ActiveSheet.Shapes.Count
        If ActiveSheet.Shapes(CtrI).Name = "GroupeOuiNon" Then
            ActiveSheet.Shapes(CtrI).Name = "GroupeOuiNon" & ActiveSheet.Shapes.Count
        End If
    Next CtrI
 
End Sub

Cordialement.

**alphonsenet** · 03/12/2013, 09h50

Bonjour,
merci beaucoup pour l'aide, c'est exactement ce que je souhaitai.
Cependant, j'avais déjà essayer de grouper les flèches mais le texte ne suivait pas.
Pourriez-vous m'indiquer la démarche faite pour grouper le texte avec le reste?
Merci d'avance.

Invité · 03/12/2013, 11h19

Envoyé par alphonsenet

Pourriez-vous m'indiquer la démarche faite pour grouper le texte avec le reste?

Il vous faut grouper les objets par leur nom et donner un nom au nouvel objet.

L'exemple, ci-dessous, crée l'objet souhaité de A à Z sur la feuille Formalisme, la réponse à votre question est à la fin

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
 
Sub CreationLosangeOuiNon(FeuilleCible As Worksheet)
 
Dim CtrI As Long
 
    FeuilleCible.Activate
 
    ' Création du losange
    ActiveSheet.Shapes.AddShape(msoShapeDiamond, 408, 79.5, 102, 87.75).Select
    Selection.Name = "Losange"
    With Selection.ShapeRange
 
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB = RGB(250, 192, 144)
 
        .Line.Weight = 1
        .Line.Visible = msoTrue
        .Line.ForeColor.RGB = RGB(0, 0, 0)
 
    End With
 
    ' Création de la flèche horizontale
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 510, 123, 581, 123).Select
    Selection.Name = "FlecheHorizontale"
    With Selection.ShapeRange
        .Line.EndArrowheadStyle = msoArrowheadOpen
        .ConnectorFormat.BeginConnect ActiveSheet.Shapes("Losange"), 4
        .Height = 0
    End With
 
    ' Création de la flèche verticale
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 459, 167, 459, 236).Select
    Selection.Name = "FlecheVerticale"
    With Selection.ShapeRange
        .Line.EndArrowheadStyle = msoArrowheadOpen
        .ConnectorFormat.BeginConnect ActiveSheet.Shapes("Losange"), 3
        .Width = 0
    End With
 
    ' Création du texte Oui
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 515, 101, 50, 17).Select
    Selection.Name = "TexteOui"
    With Selection.ShapeRange
 
        .Line.Visible = msoFalse
        .Fill.Visible = msoFalse
 
      '  .TextFrame2.VerticalAnchor = msoAnchorMiddle
        .TextFrame2.TextRange.Characters.Text = "Oui"
        .TextFrame2.TextRange.Characters(1, 3).ParagraphFormat.Alignment = msoAlignCenter
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
 
    End With
 
    ' Création du texte Non
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 465, 179, 36, 16).Select
    Selection.Name = "TexteNon"
    With Selection.ShapeRange
 
        .Line.Visible = msoFalse
        .Fill.Visible = msoFalse
 
        .TextFrame2.TextRange.Characters.Text = "Non"
        .TextFrame2.TextRange.Characters(1, 3).ParagraphFormat.Alignment = msoAlignCenter
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
 
    End With
 
    ' Groupement des objets shapes et création de l'objet "GroupeOuiNon"
     ActiveSheet.Shapes.Range(Array("Losange", "FlecheHorizontale", "FlecheVerticale", "TexteOui", "TexteNon")).Select
     Selection.ShapeRange.Group.Select
     Selection.Name = "GroupeOuiNon"
 
 
 
End Sub

Et pour tester :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub TestCreationLosangeOuiNonSurFeuilleFormalisme()
 
Dim Continuer As Boolean
Dim CtrI As Long
 
    Sheets("Formalisme").Activate
 
    Continuer = True
 
    For CtrI = 1 To ActiveSheet.Shapes.Count
        If ActiveSheet.Shapes(CtrI).Name = "GroupeOuiNon" Then Continuer = False
    Next CtrI
 
    If Continuer = True Then
        CreationLosangeOuiNon Sheets("Formalisme")
    Else
        MsgBox ("Le groupe OuiNon existe déjà !")
    End If
 
End Sub

La première réponse reste valable pour générer l'objet sur la feuille 2.

Cordialement.

Invité · 03/12/2013, 14h44

En complément de mon dernier message :

Un nom est donné automatiquement lors du groupement des objets sélectionnés. Ici par exemple Groupe 1.
Il suffit de renommer le groupement : Groupe 1 en GroupeOuiNon directement dans la zone en haut à gauche.

Renommer un groupement

Cordialement.

**alphonsenet** · 05/12/2013, 16h22

Bonjour,
désolé du retard.
J'ai réussi à renommer mes différents groupes, c'est super, un grand merci!
A très vite.

Génération de formes automatiques [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager