Création macro_mise en forme

Version imprimable

3 pièce(s) jointe(s)

Bonjour,

Je m'appelle Amaury je suis étudiant ingénieur, et je travail pour une sociéter qui fabrique des pièces de voiture.
On m'a confié un projet qui est d'améliorer l'utilisation d'un fichier excel. Malheureusement, je débute dans excel et tout ce qui est VBA et macro je ne m'y connais très peu voir quasiment pas. "Mais je sais me débrouiller..." → Exemple je joue sur la copie d'une ligne masquée pour avoir ce que je veux en rendu X) BIDOUILLAGE !

Je demande votre aide concernant une macro qui me permetterait d'insérer une ligne [COLOR="#008080"]« avec une mise en forme donc des formules copier et une flèche → voir Photo » [/COLOR]à un emplacement sélectionné en appuyant sur un seul bouton.
Pour décrire totalement ce que la macro doit faire se serait :
- Insérer une ligne au dessus de la cellule sélectionné
- Copier les formules de la ligne du dessus de C→AB
- Les collers dans la ligne insérer
- Enlever la bordure gauche de la cellule en B "+mettre en fond blanc A+B → Pas obligatoire"
- et insérer une flèche en B
Voici le code:
Code:

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 Sub test_macro_mise_en_forme() ' ' test_macro_mise_en_forme Macro ' ' Rows(ActiveCell.Row).Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("A8:B8").Select Range("B8").Activate With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 .PatternTintAndShade = 0 End With Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Selection.Borders(xlInsideHorizontal).LineStyle = xlNone Range("C7:AB7").Select Selection.Copy Range("C8").Select ActiveSheet.Paste Range("B8").Select Application.CutCopyMode = False Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone Range("L12").Select ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 55.7142519685, _ 207.8571653543, 202.5, 227.1428346457).Select Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadOpen With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) .Transparency = 0 End With Range("F8").Select End Sub
APERCU DE BASE
Pièce jointe 195646

APERCU FINAL
Pièce jointe 195645

J'ai cherché sur vraiment pas mal de forum mais malheuresement je n'ai rien trouvé concernant les ranges pour quelles suivent une selection effectué précédement.
Je vous remercie d'avance pour votre aide. J'espère juste que vous avez pu comprend un peu ce que je voulais haha.

PS: J'ai mis le fichier excel en pièce jointe pour que vous puissiez voir la chose plus simplement. ONGLET → Relevé tps cycle OP

18/12/2015, 11h56
Minise

c'est bizarre que tu y arrives la première fois et ensuite non, le problème c'est que ça insère pas au bon endroit ou tu as un message d'erreur ?
18/12/2015, 13h35
Sebphyto

Salut,

Ton code la prochaine fois ou alors édite-le mais
:tagcode:

C'est beaucoup plus lisible pour ceux qui veulent d'aider....

Citation:

Pour décrire totalement ce que la macro doit faire se serait :
- Insérer une ligne au dessus de la cellule sélectionné

ca c bon

Citation:

- Copier les formules de la ligne du dessus de C→AB

Idem c bon

Citation:

- Les coller dans la ligne insérer

pareil

Citation:

- Enlever la bordure gauche de la cellule en B "+mettre en fond blanc A+B → Pas obligatoire"

idem

Citation:

- et insérer une flèche en B

idem c bon

Bon en faite ce que tu veux c faire varier les "ranges" en fonction de ta cellule préalablement sélectionnée manuellement????

Seb
18/12/2015, 13h41
amaury57280

C'est tout à fait ça. Les ranges me bloque les positions :(

J'ai changé l'apercu du code :) Je ne connaissais pas ce type de balises.
18/12/2015, 13h43
Sebphyto

re,
je regarde ça dans l'après midi....;)
18/12/2015, 13h47
amaury57280

Super merci beaucoup :)
j'essaye encore de mon coter en "trichant" en copiant ma flèche pour quelle arrête de m'embêter avec sa position mais j'ai du mal :(. Il faut vraiment que je me mette au tutoriel...

Re,

Bon essai avec ça normalement cela convient à tes désir
Désolé pour le retard

Code:

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
92
93
94
95
96
97
98
99
100
101
102
Sub test_macro_mise_en_forme()
 
    'active ligne complète de la selection manuelle de la cellule
    Rows(ActiveCell.Row).Select
 
    'Insérer une ligne au dessus de la cellule sélectionné
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A" & (ActiveCell.Row), "B" & (ActiveCell.Row)).Select
 
    Range("B" & (ActiveCell.Row)).Activate
 
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
 
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
 
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
 
    'Copier les formules de la ligne du dessus de C -->AB
    Set Maplage = Range("C" & (ActiveCell.Row - 1), "AB" & (ActiveCell.Row - 1))
    Maplage.Select
    'Range("C7:AB7").Select
    Maplage.Copy
 
    'Les coller dans la ligne insérer
    Set macopie = Range("C" & (ActiveCell.Row + 1), "AB" & (ActiveCell.Row + 1))
    macopie.Select
 
    ActiveSheet.Paste
    Range("B" & (ActiveCell.Row)).Activate
    'Range("B8").Select
 
    Application.CutCopyMode = False
 
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
 
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
 
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    'Range("L12").Select
 
    ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 55.7142519685, _
        207.8571653543, 202.5, 227.1428346457).Select
    Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadOpen
 
        With Selection.ShapeRange.Line
            .Visible = msoTrue
            .ForeColor.RGB = RGB(0, 0, 0)
            .Transparency = 0
        End With
 
    'Range("F8").Select
End Sub

Pour info j'ai mis

Code:

1
2
'Range("F12").Select
'Range("F8").Select

en commentaire car je ne vois pas à quoi ils servent

Et je n'ai pas non plus simplifié ton code qui pourrait l'être grandement.....il faut éviter le plus possible les (select) et (selection)

Seb

Ne pas oublier de plusser :plusser:

19/12/2015, 14h28
amaury57280

Presque !

Salut alors la macro fait la copie de formule mais la Fleche reste toujours à la même place en B8 :( elle ne suit pas l'insertion.
Mais merci d'avoir éssayer je vais éssayer de regarder tes changements et de les appliquers à la flèche.
19/12/2015, 15h22
Sebphyto

Salut Amaury,

Citation:

la copie de formule mais la Fleche reste toujours à la même place

C'est vrai....mais

j'ai trouvé un truc qui pourrai te convenir, par contre je n'ai pas le temps aujourd'hui....:roll:

Je regarde ça rapidement si cela te convient

Seb
20/12/2015, 13h23
amaury57280

:)

Pas de soucis :) prend ton temps :) je regarde en même temps de mon côter mais j'ai du mal a trouver des tutos correct :((
20/12/2015, 14h04
Sebphyto

re
ok merci
Mais pour t'aiguiller il faut récupérer les coordonnées "top et left" de la cellule nouvellement créer.....

1 pièce(s) jointe(s)

Salut Sebphyto,

Alors, j'ai regardé à quoi correspondait les coordonnées qu'il y avait pour la position de la flèche

Pièce jointe 195866

Le premier est la position du début de la flèche sur X
Le deuxième est la position du début de la flèche sur Y
Le troisième est la position de la fin de la flèche sur X
Le quatrième est la position de la fin de la flèche sur Y

j'ai testé ça avec le code là: "j'ai mit un 0 dans les coordonnées un par un et j'ai regardé ce que ça faisait"
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 Sub Flèche() ' ' Flèche Macro ' ' ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 56.7857480315, _ 319.2857480315, 204.6428346457, 0).Select Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadOpen Selection.ShapeRange.ShapeStyle = msoLineStylePreset1 With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) .Transparency = 0 End With End Sub
Par contre, je vais pas te mentir mais j'ai l'impression c'est limite pas faisable mon truc étant donné que les coordonnées n'ont rien à voir avec la taille des cellules. Ma cellule A faisait 10 et pour démarrer à la fin de la cellule A il faut 51,.... Donc je sais pas trop quoi pensait du coup :(. À moins qu'on puisse changer ces coordonnées en points genre un début de case B et la ligne inséré. Mais franchement ça je vois pas du tout comment faire.
Je vais encore regarder aujourd'hui pour trouver comment gérer les coordonnées d'une formes.

21/12/2015, 09h18
Sebphyto
Salut Amaury,

JE pense que j'ai trouvé comment faire, il me faut un peu de temps (aujourd'hui seulement)....en faite il faut de toute façon créer une forme (en gros un modèle), qui ne sera pas dans activecell au début, et après la déplacer...
avec ce type de code
Code:

1 2 Selection.ShapeRange.IncrementLeft ActiveCell.Left Selection.ShapeRange.IncrementTop ActiveCell.Top
J'ai modifié ton code et créé une function avec la shape....

Je reviens vers toi quand j'ai trouvé un truc solide.
seb
21/12/2015, 09h52
amaury57280
Citation:
Envoyé par Sebphyto

Code:

1 2 Selection.ShapeRange.IncrementLeft ActiveCell.Left Selection.ShapeRange.IncrementTop ActiveCell.Top
Ah oui d'accord je vois le truc ! et tu crois que dans les 4coordonnées c'est possible pour la position de hauteur on puisse mettre un IncrementTop ?
Je vais éssayer des trucs et je vérrais. j'ai également éssayé de copier la ligne avec la forme et sa fait bug excel X) Donc j'ai vite abandonné cette idée.

1 pièce(s) jointe(s)

J'y arrive mais en 4 maccro ...

→ "Copie ligne"
→ Clique sur une cellule et "colle ligne"
→ "Copie forme"
→ Clique sur la cellule inséré en B et "colle forme"

Et sa fonctionne partout. Après j'ai éssayer de la mettre en 1 formule mais sa beg sa me fait de la scheiße à cause de la sélection faudrait que je trouve le bon ordre. Après je ne sais pas comment cacher mes deux lignes à copier pour ne pas les voirs sans interagir avec le copie/coller.
Code:

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 Sub copie_ligne() ' ' copie_ligne Macro ' ' Rows("3:3").Select Selection.Copy End Sub Sub Coller_ligne() ' ' Coller_ligne Macro ' ' Rows(ActiveCell.Row).Select Selection.Insert Shift:=xlDown Range("F14").Select End Sub Sub Copie_forme() ' ' Copie_forme Macro ' ' ActiveSheet.Shapes.Range(Array("Elbow Connector 45")).Select Selection.Copy End Sub Sub Coller_forme() ' ' Coller_forme Macro ' ' Range("B" & ActiveCell.Row).Select ActiveSheet.Paste End Sub

Bon c'est bon voici le code, j'ai fait autrement qu'avec "increment"
Je positionne le shape dans la cellule après l'avoir créer au préalable en A1, sans rien voir à l'écran.

Code:

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
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
Sub test_macro_mise_en_forme()
 
    Application.ScreenUpdating = False
 
    'active ligne complète de la selection manuelle de la cellule
    Rows(ActiveCell.Row).Select
 
    'Insérer une ligne au dessus de la cellule sélectionné
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A" & (ActiveCell.Row), "B" & (ActiveCell.Row)).Select
 
    Range("B" & (ActiveCell.Row)).Activate
 
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
 
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
 
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
 
    'Copier les formules de la ligne du dessus de C -->AB
    Set Maplage = Range("C" & (ActiveCell.Row - 1), "AB" & (ActiveCell.Row - 1))
    Maplage.Select
    'Range("C7:AB7").Select
    Maplage.Copy
 
    'Les coller dans la ligne insérer
    Set macopie = Range("C" & (ActiveCell.Row + 1), "AB" & (ActiveCell.Row + 1))
    macopie.Select
 
    ActiveSheet.Paste
    Range("B" & (ActiveCell.Row)).Activate
    'Range("B8").Select
 
    Application.CutCopyMode = False
 
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
 
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
 
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    'Range("L12").Select
 
    'ActiveCell.Top et ActiveCell.Left = coordonnées de la cellule active
 
    BeginY = ActiveCell.Left
    BeginX = ActiveCell.Top
    AdresCell = ActiveCell.Address
 
    ShapesADD PosGauche, PosHaut
 
    Application.ScreenUpdating = True
    'Range("F8").Select
End Sub
 
 
Function ShapesADD(BeginX, BeginY)
'Shapes.AddConnector(Type, BeginX, BeginY, EndX, EndY)
'Position horizontale de départ du connecteur par rapport au coin supérieur gauche du document= beginX
'Position verticale de départ du connecteur par rapport au coin supérieur gauche du document = BeginY
'Position horizontale de fin du connecteur par rapport au coin supérieur gauche du document= EndX
'Position verticale de fin du connecteur par rapport au coin supérieur gauche du document= EndY
EndY = 202.5
EndX = 227.1428346457
 
    With Range("B" & (ActiveCell.Row)).Activate
        With ActiveSheet
            .Shapes.AddConnector(msoConnectorElbow, BeginX, _
            BeginY, EndX, EndY).Select
 
            'Positionnement sur une cellule:
            .Shapes(Selection.Name).Top = ActiveCell.Top
            .Shapes(Selection.Name).Left = ActiveCell.Left
 
        End With
        With Selection
            .ShapeRange.ScaleWidth 0.6478871733, msoFalse, msoScaleFromTopLeft
            .ShapeRange.ScaleHeight 0.0741914453, msoFalse, msoScaleFromTopLeft
 
                With .ShapeRange.Line
                        .EndArrowheadStyle = msoArrowheadOpen
                        .Visible = msoTrue
                        .ForeColor.RGB = RGB(0, 0, 0)
                        .Transparency = 0
                End With
        End With
    End With
 
End Function

J'espère que ça te convient

Seb

Citation:

Envoyé par Sebphyto

Code:

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
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
Sub test_macro_mise_en_forme()
 
    Application.ScreenUpdating = False
 
    'active ligne complète de la selection manuelle de la cellule
    Rows(ActiveCell.Row).Select
 
    'Insérer une ligne au dessus de la cellule sélectionné
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A" & (ActiveCell.Row), "B" & (ActiveCell.Row)).Select
 
    Range("B" & (ActiveCell.Row)).Activate
 
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
 
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
 
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
 
    'Copier les formules de la ligne du dessus de C -->AB
    Set Maplage = Range("C" & (ActiveCell.Row - 1), "AB" & (ActiveCell.Row - 1))
    Maplage.Select
    'Range("C7:AB7").Select
    Maplage.Copy
 
    'Les coller dans la ligne insérer
    Set macopie = Range("C" & (ActiveCell.Row + 1), "AB" & (ActiveCell.Row + 1))
    macopie.Select
 
    ActiveSheet.Paste
    Range("B" & (ActiveCell.Row)).Activate
    'Range("B8").Select
 
    Application.CutCopyMode = False
 
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
 
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
 
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    'Range("L12").Select
 
    'ActiveCell.Top et ActiveCell.Left = coordonnées de la cellule active
 
    BeginY = ActiveCell.Left
    BeginX = ActiveCell.Top
    AdresCell = ActiveCell.Address
 
    ShapesADD PosGauche, PosHaut
 
    Application.ScreenUpdating = True
    'Range("F8").Select
End Sub
 
 
Function ShapesADD(BeginX, BeginY)
'Shapes.AddConnector(Type, BeginX, BeginY, EndX, EndY)
'Position horizontale de départ du connecteur par rapport au coin supérieur gauche du document= beginX
'Position verticale de départ du connecteur par rapport au coin supérieur gauche du document = BeginY
'Position horizontale de fin du connecteur par rapport au coin supérieur gauche du document= EndX
'Position verticale de fin du connecteur par rapport au coin supérieur gauche du document= EndY
EndY = 202.5
EndX = 227.1428346457
 
    With Range("B" & (ActiveCell.Row)).Activate
        With ActiveSheet
            .Shapes.AddConnector(msoConnectorElbow, BeginX, _
            BeginY, EndX, EndY).Select
 
            'Positionnement sur une cellule:
            .Shapes(Selection.Name).Top = ActiveCell.Top
            .Shapes(Selection.Name).Left = ActiveCell.Left
 
        End With
        With Selection
            .ShapeRange.ScaleWidth 0.6478871733, msoFalse, msoScaleFromTopLeft
            .ShapeRange.ScaleHeight 0.0741914453, msoFalse, msoScaleFromTopLeft
 
                With .ShapeRange.Line
                        .EndArrowheadStyle = msoArrowheadOpen
                        .Visible = msoTrue
                        .ForeColor.RGB = RGB(0, 0, 0)
                        .Transparency = 0
                End With
        End With
    End With
 
End Function

O_O WTH "What The Hell" :D Merci énormément. Je suis sur le cul HAHA ! Moi qui éssaye avec des MsgBOX de bloquer les étapes pour sélectionner manuellement ma plage X)
D'où sors-tu extraterrestre de la programmation X))))
Franchement je m'attendais pas à un code de malade à ce point ! je vais étudier ça et voir qu'est-ce qui est dedans. Mais franchement merci énormément !
Comment as-tu appris a faire ça ?

21/12/2015, 11h48
Sebphyto

MErci merci 8-)

J'ai appris sur le tas (autodidacte), Google est ton ami et les personnes du forum sont des génies pour l'apprentissage (merci à eux en passant, il se reconnaitrons :D)
Juste pour info, je n'avais jamais auparavant manipulé d'objet "Shape" donc comme quoi on apprend en même temps.....;)

Oublies pas de plusser les conversations :plusser:

Bonne continuation
seb
21/12/2015, 13h19
amaury57280

À vrai c'était ma première "vraie macro" donc bon :P
Encore merci ! je vais me mettre au tuto dans peu de temps :)

Bonne continuation.