Exécuter macro avec un double clic

Version imprimable

14/03/2014, 13h48
Etudiante113475

Exécuter macro avec un double clic
Bonjour,
Je souhaiterai exécuter une macro automatiquement lorsque un utilisateur double clique dans une cellule.

J'ai pu trouver ce code sur google:
Code:

1 2 3 4 5 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'Nom de la macro End Sub
J'ai écrit ce code dans le code de ma feuille où se trouve mon tableau croisé dynamique et dans le quel il faut double cliquer mais cela ne marche pas, je n'arrive pas à le lancer.
Je sais donc entrer le code (si c'est bien le bon) mais je ne sais pas quelle procédure est ensuite à utiliser.
Quelle est donc la procédure à suivre pour que quand j'ouvre mon fichier Excell, sans ouvrir Visual Basic, la macro se mette en marche en cliquand dans mon TCD?

Merci pour votre aide
14/03/2014, 14h34
vins86

Bonjour,

Peux-tu mettre ton code à exécuter.

Cordialement,

Vincent
14/03/2014, 14h44
NicolasST

Citation:

Envoyé par Etudiante113475

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

'Nom de la macro

End Sub

Est une macro évenementielle.
Elle existe par défaut sur chaque feuille.

Pour cela allez dans VBA

Dans la fenêtre VBAProject qui normalement s'ouvre automatiquement en haut à gauche,
double cliquer sur la feuille pour laquelle vous voulez activer cette fonction.

Dans la fenêtre qui s'ouvre alors, en haut,
remplacer avec le menu déroulant (general) par Worksheet

Puis sur le menu déroulant de droite choisir "BeforeDoubleClick"

La macro va alors s'afficher,
il vous restera plus qu'à y mettre le code que vous voulez appeler.
14/03/2014, 15h00
Etudiante113475

Merci, je pense que je ne dois pas rentrer un nom de macro car cela m'indique:

"Erreur de compilation:
Variable ou procédure attendue, et non un module"

J'ai effectivement rentrer le nom de mon module que j'ai rennomé mise_en_forme_macro

Où est alors le nom de la macro car je vois que celà?

Merci

Voici le code à adapter comme tu veux. =)

Code:

1
2
3
4
5
6
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Plg As Range
Set Plg = Range("D5:J57")  'plage à adapter
MsgBox "bonjour"
 
End Sub

Cordialement,

14/03/2014, 15h36
Etudiante113475

Merci, mais cela ne marche pas, cela m'affiche juste bonjour

Voici le code que tu demandes:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Plg As Range
Set Plg = Range("D5:J57")  'plage à adapter
Call DeList
Call extraction_feuille
Call Trier4
Call Sous_totaux3
Call format_monnaie
Call coloriage2
Call ajuster_colonne
Call mise_en_forme_titre
Call bordure_1
Call bordure_2
Call destruction_col_M
Call Colonne_total
Call zoom_75
DoEvents
End Sub

14/03/2014, 16h13
Etudiante113475

Cela m'affiche:

Erreur de compilation:
Sub ou Function non définie

:?

essaye çà:

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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Plg As Range
Set Plg = Range("D5:J57")  'plage à adapter
Call DeList
Call extraction_feuille
Call Trier4
Call Sous_totaux3
Call format_monnaie
Call coloriage2
Call ajuster_colonne
Call mise_en_forme_titre
Call bordure_1
Call bordure_2
Call destruction_col_M
Call Colonne_total
Call zoom_75
DoEvents
End Sub
 
Sub DeList()
Dim wrksht As Worksheet
Dim objListObj As ListObject
 
Set wrksht = ActiveWorkbook.ActiveSheet
Set objListObj = wrksht.ListObjects(1)
objListObj.Unlist
 
extraction_feuille
 
End Sub
 
 
 
Sub extraction_feuille()
ActiveSheet.Move
ActiveSheet.Name = ("Feuil1")
 
Trier4
End Sub
Sub Trier4()
'
' Trier4 Macro
'
 
'
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range( _
"G2:G177438"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range( _
"I2:I177438"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range( _
"A2:A177438"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").Sort
.SetRange Range("A1:O177438")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sous_totaux3
End Sub
 
 
Sub Sous_totaux3()
'
' Sous_totaux3 Macro
'
 
'
'ActiveSheet.PageSetup.PrintArea = Selection
Range("A1").CurrentRegion.Select
 
Selection.Subtotal GroupBy:=7, Function:=xlSum, TotalList:=Array(10, 11, 12 _
, 13, 14), Replace:=False, PageBreaks:=False, SummaryBelowData:=True
 
Range("A1").CurrentRegion.Select
Selection.Subtotal GroupBy:=9, Function:=xlSum, TotalList:=Array(10, 11, 12 _
, 13, 14), Replace:=False, PageBreaks:=False, SummaryBelowData:=True
 
 
format_monnaie
End Sub
Sub format_monnaie()
'
' format_monnaie Macro
'
 
'
Range("J:K,M:N").Select
Range("M1").Activate
Selection.NumberFormat = _
"_-* #,##0.00 [$€-40C]_-;-* #,##0.00 [$€-40C]_-;_-* ""-""?? [$€-40C]_-;_-@_-"
coloriage1
End Sub
 
 
Private Sub coloriage1()
 
Dim c As Range
Dim firstAddress As Variant
 
With Range("I:I")
Set c = .Find("Total")
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Offset(0, -8).Resize(1, 15).Interior.ColorIndex = 42
c.Offset(0, -8).Resize(1, 15).Font.Bold = True
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
coloriage2
End Sub
Private Sub coloriage2()
 
Dim c As Range
Dim firstAddress As Variant
 
With Range("G:G")
Set c = .Find("Total")
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Offset(0, -6).Resize(1, 15).Interior.ColorIndex = 44
c.Offset(0, -6).Resize(1, 15).Font.Bold = True
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
ajuster_colonne
End Sub
Sub ajuster_colonne()
'
' ajuster_colonne Macro
'
 
'
Range("A1").CurrentRegion.Select
Selection.Columns.AutoFit
mise_en_forme_titre
End Sub
Sub mise_en_forme_titre()
'
' mise_en_forme_titre Macro
'
 
'
Range("A1:O1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
bordure1
End Sub
 
Sub bordure1()
'
' Bordure Macro
'
 
'
Range("A1").CurrentRegion.Select
 
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlThin
End With
bordure2
End Sub
Sub bordure2()
'
' titre Macro
'
 
'
Range(Cells(1, 1), Cells(1, 15)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
 
destruction_col_M
End Sub
Private Sub destruction_col_M()
Columns("M:M").Delete Shift:=xlToLeft
 
Colonne_total
End Sub
Sub Colonne_total()
'
' Colonne_total Macro
'
 
'
Columns("M:M").Select
Selection.ColumnWidth = 18
Columns("L:L").Select
Selection.ColumnWidth = 4
 
zoom75
End Sub
 
 
Private Sub zoom75()
 
ActiveWindow.Zoom = 75
 
End Sub

14/03/2014, 16h21
Etudiante113475

Ca fait pareil :'(

J'ai fait une correction dans tes codes:

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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Plg As Range
Set Plg = Range("D5:J57")  'plage à adapter
Call DeList
Call extraction_feuille
Call Trier4
Call Sous_totaux3
Call format_monnaie
Call coloriage2
Call ajuster_colonne
Call mise_en_forme_titre
Call bordure_1
Call bordure_2
Call destruction_col_M
Call Colonne_total
Call zoom_75
DoEvents
End Sub
 
Sub DeList()
Dim wrksht As Worksheet
Dim objListObj As ListObject
 
Set wrksht = ActiveWorkbook.ActiveSheet
Set objListObj = wrksht.ListObjects(1)
objListObj.Unlist
 
 
End Sub
 
 
 
Sub extraction_feuille()
ActiveSheet.Move
ActiveSheet.Name = ("Feuil1")
 
End Sub
Sub Trier4()
'
' Trier4 Macro
'
 
'
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range( _
"G2:G177438"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range( _
"I2:I177438"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range( _
"A2:A177438"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").Sort
.SetRange Range("A1:O177438")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
 
 
Sub Sous_totaux3()
'
' Sous_totaux3 Macro
'
 
'
'ActiveSheet.PageSetup.PrintArea = Selection
Range("A1").CurrentRegion.Select
 
Selection.Subtotal GroupBy:=7, Function:=xlSum, TotalList:=Array(10, 11, 12 _
, 13, 14), Replace:=False, PageBreaks:=False, SummaryBelowData:=True
 
Range("A1").CurrentRegion.Select
Selection.Subtotal GroupBy:=9, Function:=xlSum, TotalList:=Array(10, 11, 12 _
, 13, 14), Replace:=False, PageBreaks:=False, SummaryBelowData:=True
 
 
End Sub
Sub format_monnaie()
'
' format_monnaie Macro
'
 
'
Range("J:K,M:N").Select
Range("M1").Activate
Selection.NumberFormat = _
"_-* #,##0.00 [$€-40C]_-;-* #,##0.00 [$€-40C]_-;_-* ""-""?? [$€-40C]_-;_-@_-"
End Sub
 
 
Private Sub coloriage1()
 
Dim c As Range
Dim firstAddress As Variant
 
With Range("I:I")
Set c = .Find("Total")
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Offset(0, -8).Resize(1, 15).Interior.ColorIndex = 42
c.Offset(0, -8).Resize(1, 15).Font.Bold = True
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
Private Sub coloriage2()
 
Dim c As Range
Dim firstAddress As Variant
 
With Range("G:G")
Set c = .Find("Total")
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Offset(0, -6).Resize(1, 15).Interior.ColorIndex = 44
c.Offset(0, -6).Resize(1, 15).Font.Bold = True
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
Sub ajuster_colonne()
'
' ajuster_colonne Macro
'
 
'
Range("A1").CurrentRegion.Select
Selection.Columns.AutoFit
End Sub
Sub mise_en_forme_titre()
'
' mise_en_forme_titre Macro
'
 
'
Range("A1:O1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
End Sub
 
Sub bordure1()
'
' Bordure Macro
'
 
'
Range("A1").CurrentRegion.Select
 
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlThin
End With
End Sub
Sub bordure2()
'
' titre Macro
'
 
'
Range(Cells(1, 1), Cells(1, 15)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
 
End Sub
Private Sub destruction_col_M()
Columns("M:M").Delete Shift:=xlToLeft
 
End Sub
Sub Colonne_total()
'
' Colonne_total Macro
'
 
'
Columns("M:M").Select
Selection.ColumnWidth = 18
Columns("L:L").Select
Selection.ColumnWidth = 4
 
End Sub
 
 
Private Sub zoom75()
 
ActiveWindow.Zoom = 75
 
End Sub

17/03/2014, 10h09
Etudiante113475

Merci, mais cela ne marche toujours pas chez moi... Tant pis, merci quand même pour votre aide!