Macros combinées qui ne fonctionnent pas

**graphikris** · 22/01/2016, 17h14

Bonjour,

Dans un classeur Excel, je posséde comme beaucoup d'entre vous, des macros qui fonctionnent très bien.

Lorsque j'essaye de les mettre dans "ThisWorkbook" "Open" en les enchaînant avec CALL, elles ne fonctionnent plus. Cà bug dès que ça arrive sur Call.

J'ai donc essayé de les coller tout simplement et là, ça bug à certaines lignes alors que si je déclenche ces mêmes macros dans un module, là tout fonctionne.

Quelqu'un aurait il une idée afin de savoir d'où ça vient ?

Voici le code qui fonctionne dans ThisWorkbook :

NOTA : A la ligne 24, j'appelle une macro se situant dans un module (celle ci fonctionne bien dans "Open")
Par contre a la ligne 30, je dois faire appel à la macro du second code se situant plus bas. Si je fais Call Envoi_Mail_fiches_non_analysee, ça bug (voir explication dans le 3eme code joint)
J'ai également rajouter en ligne 29, ce code. Il permet de déclencher la macro le 1er jour ouvré du mois (ce code fonctione bien)

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
'Pour envoi mail auto 1er jour ouvré du mois
 
   With Sheets("Accueil").Range("A1")
   'Cells(Rows.Count, Columns.Count) ' adapte l'index ou le nom du sheets
        If .Value <> Month(Date) Then
            .Value = Month(Date)
            ThisWorkbook.Save
   '
   'ICI SE TROUVE LA LIGNE 30 du "ThisWorkbook"    
 
    End If
    End With
 
 
 
 Windows("Base de données.xlsm").Activate
 Sheets("Accueil").Select
    Range("A1").Select
    ActiveSheet.Protect

ICI CODE du ThisWorkbook

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
Private Sub Workbook_Open()
 
 isreadonly
End Sub
 
Sub isreadonly()
    If ThisWorkbook.ReadOnly Then
MsgBox "Une personne du Bureau utilise déjà la base de données, vous ne pouvez pas l'ouvrir actuellement. Veuillez réessayer ultérieurement"
 
ThisWorkbook.Close False
    End If
 
' RAZ_Ouverture Macro
 
    Sheets("Accueil").Select
 
' indication heure et date
    CreateObject("Wscript.shell").Popup "Bonjour," & Chr$(13) & Chr$(13) & "nous sommes le " & Date & ", il est exactement " & Time & "." & Chr$(13) & Chr$(13) & "Une réinitialisation des cellules de la base de données va avoir lieu." & Chr$(13) & Chr$(13) & "Attendre le retour sur la page d'accueil avant toute manipulation.", 10, "Application développée par PC.", vbExclamation
 
Sheets("Accueil").Select
    Range("A1").Select
    ActiveSheet.Unprotect  
 
    Call Tri_Suivi_referentiel_Documentaire
 
' Opération terminée
Sheets("Accueil").Select
    CreateObject("Wscript.shell").Popup "Opération effectuée avec succès. " & Chr$(13) & "Vous pouvez travailler en toute tranquilité.", 8, "Application développée par PC.", vbInformation
 
'ICI JE DOIS INSERER LA MACRO DU MODULE CI DESSOUS
 
End Sub

Second Code : Code de la Macro qui fonctionne bien dans un module :

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
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
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
Sub Envoi_Mail_fiches_non_analysee()
'
'
    rep = MsgBox("Création d'un @mail automatique concernant  les Fiches ouvertes dont le délai d'analyse est supérieur à 30 jours. En cas d'erreur, ne vous affolez pas, une confirmation d'envoi vous sera demandée ultérieurement.", vbYes + vbInformation, "Transmission de mail automatique...")
 
    Dim nom As String
    Dim Wbk As Workbook
    Set Wbk = Workbooks.Add
 
    Sheets("Feuil1").Select
    Sheets("Feuil1").Name = "Envoi Mail"
    Sheets("Feuil2").Select
    Sheets("Feuil2").Name = "Matrice Mail"
 
    Windows("Base de données.xlsm").Activate
 
    Sheets("Fiche de Progres").Select
    ActiveSheet.Unprotect
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=18, Criteria1:= _
        "Ouverte"
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=21, Criteria1:= _
        "Oui"
    Range("A1:w500").Select
    Selection.Copy
    Wbk.Activate
    ActiveSheet.Paste
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("H:H").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Columns("H:I").Select
    Selection.Delete Shift:=xlToLeft
    Columns("I:I").Select
    Selection.Delete Shift:=xlToLeft
    Columns("J:J").Select
    Selection.Delete Shift:=xlToLeft
    Columns("K:K").Select
    Selection.Delete Shift:=xlToLeft
    Columns("K:K").Select
    Selection.Delete Shift:=xlToLeft
    Columns("L:M").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
 
 
    'Ligne de titre
    ActiveSheet.Unprotect
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1:k1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Rows("1:1").RowHeight = 35
    Range("A1:K1").Select
    ActiveCell.FormulaR1C1 = "Fiches non analysées depuis plus d'un mois"
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "Edition du :"
    Range("A1:K2").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    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
    Rows("3:3").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A2").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "=TODAY()"
    Range("B2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1:m1").Select
    Selection.Font.Bold = True
    Selection.Font.Size = 20
    Range("A2:B2").Select
    Selection.Font.Bold = True
    Selection.Font.Size = 10
    Range("A4:m4").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    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 = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    ActiveWindow.DisplayGridlines = False
    ActiveWindow.DisplayHeadings = False
 
 
 
    'Coupe puis colle colonnes L et M sur feuille 2
    Range("L4:L53").Select
    Selection.Cut
    Sheets("Envoi Mail").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Matrice Mail").Select
    Range("M5:M54").Select
    Selection.Cut
    Sheets("Envoi Mail").Select
    ActiveWindow.SmallScroll Down:=18
    Range("A51").Select
    ActiveSheet.Paste
 
    'Adresses des personnes en copie du mail
    Rows("3:3").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "TOTO@test.fr"
    Sheets("Matrice Mail").Select
    Range("M4").Select
    Selection.Delete
    ActiveWorkbook.Names.Add Name:="p", RefersToR1C1:="='Matrice Mail'!R1C16"
    Selection.Delete Shift:=xlToLeft
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Range("A4").Select
 
 
 
    'Boite dialogue de confirmation d envoi du mail
 
 
   Select Case MsgBox("Désirez-vous transmettre cet @mail ?", vbYesNo, "Application développée par PC.")
   Case vbYes
        'procédure si click sur Oui
   'Envoi du mail
   Dim olapp As Outlook.Application
Dim malist, Count, Envoi
Dim i
            '-------Contrôler dans Visual Basic/Outils/Références/que Microsoft Outlook --,- Object Librairy est bien coché
Sheets("Envoi Mail").Select
 
With Sheets("Envoi Mail")
 
'Suppression des adresses en doublons
Columns("A:A").Select
    Range("A19").Activate
    ActiveSheet.Range("$A$1:$A$100").RemoveDuplicates Columns:=1, Header:=xlYes
    ActiveWorkbook.Worksheets("Envoi Mail").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Envoi Mail").Sort.SortFields.Add Key:=Range( _
        "A2:A100"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Envoi Mail").Sort
        .SetRange Range("A1:A100")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWindow.SmallScroll Down:=-30
    Range("A1").Select
 
 
 
    Dim adresse(1 To 150)
                '----------------------Création de la liste d'adresses mail contenus de la ligne 2 à 151
    Set malist = Sheets("Envoi Mail").Range("A2:A151")
    Count = 1
    For Each Envoi In malist
    If Len(Envoi) Then adresse(Count) = Envoi: Count = Count + 1
    Next
                '----------------------Copie de la liste d'adresse dans une cellule vide exemple H1
    For i = 1 To 150
        If adresse(i) = "" Then Exit For
        If adresse(i) Like "*@*" Then .[H1] = .[H1] & ";" & adresse(i)
    Next i
 
    '-------adresse du répertoire ou sera enregistré le fichier
       AdresseRépertoire = ActiveWorkbook.Path
 
                '---------------------copie de la feuille à envoyer
    Application.DisplayAlerts = False
    Sheets("Matrice Mail").Copy
                '---------------------Nom du fichier à envoyer
   Fichier = ThisWorkbook.Path & "\Fiche non analysee transmis par mail le " & _
              Replace(Replace(Replace(Left(Now, 16), ":", "h"), " ", " à "), "/", "-") & ".xlsx"
 
    ActiveWorkbook.SaveAs Fichier
    ActiveWorkbook.Close
                '---------------------Envoi par mail
    Sheets("Envoi Mail").Select
    .Range("H1").Select
                '---------------------contrôle la validité ou la présence d'adresse mail en H1
    Dim msg As MailItem
    Set olapp = New Outlook.Application
    Set msg = olapp.CreateItem(olMailItem)
    msg.To = .Range("H1").Value 'Adresse de la cellule contenant la liste des adresses mails
                '--------------------Saisir le sujet de l'envoi
    msg.Subject = "Etat des Fiches dontt le délai d'analyse est supérieur à 30 jours."
    '---------------------saisie du message
                '------------------- Saisir Corps du message
     msg.Body = "Mail mensuel généré automatiquement ."
 
                '---------------------Adresse de la pièce jointe
     msg.Attachments.Add Source:=Fichier
    'msg.Attachments.Add Source:=ThisWorkbook.Path & "\nom fichier Excel.xlsm"
    msg.Display
    msg.Send
 
 
 
End With
 
 
   rep = MsgBox("Une copie de la pièce jointe a été transmise vers U:\Groupes fonctionnels", vbYes + vbInformation, "Transmission de mail automatique...")
 
   Select Case MsgBox("Désirez-vous fermer ce classeur ?", vbYesNo, "Application développée par PC.")
   Case vbYes
        'procédure si click sur Oui
        ActiveWindow.Close
   rep = MsgBox("Fermeture du classeur effectuée.", vbYes + vbInformation, "Sélection nouvelle requête / Application développée par PC.")
   Windows("Base de données BQI.xlsm").Activate
    Sheets("Fiche de progres").Select
    Range("A1").Select
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=18
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=21
    Rows("1:1").Select
    Selection.AutoFilter
    Range("A1").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Range("A1").Select
    Sheets("Requetes").Select
   Case vbNo
       'procédure si click sur Non
   Windows("Base de données BQI.xlsm").Activate
   Sheets("fiche de progres").Select
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=18
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=21
    Rows("1:1").Select
    Selection.AutoFilter
    Range("A1").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Range("A1").Select
    Sheets("Accueil").Select
    End Select
 
   Case vbNo
       'procédure si click sur Non
   ActiveWindow.Close
   rep = MsgBox("Votre courriel ne sera pas transmis. Fermeture du classeur effectuée.", vbYes + vbInformation, "Annulation transmission de courriel / Application développée par PC.")
   Windows("Base de données BQI.xlsm").Activate
   Sheets("fiche de progres").Select
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=18
    Rows("1:1").Select
    Selection.AutoFilter
    Range("A1").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Range("A1").Select
    Sheets("Requetes").Select
    End Select   
 
End Sub

Aprés avoir inséré ce code a la ligne 30 de ThisWorkbook,ça bug aux lignes 10 à 13, j'ai donc remplacé par ce code :

Troisième code joint :

Code :

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

1
2
3
4
With Wbk
   .Sheets(1).Name = "Envoi Mail"
   .Sheets(2).Name = "Matrice Mail"
End With

et là, ça bug à la ligne 28 du second code :

Code :

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

ActiveSheet.Paste

Ne sachant plus quoi faire, je fais appel à vos lumières (plutôt lampe au Xénon) pour m'aider.
Pour résumer voici le code complet (qui bug) de Thisworkbook (ici ligne 75) :

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
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
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
Private Sub Workbook_Open()
 
 isreadonly
End Sub
 
Sub isreadonly()
    If ThisWorkbook.ReadOnly Then
MsgBox "Une personne du Bureau utilise déjà la base de données, vous ne pouvez pas l'ouvrir actuellement. Veuillez réessayer ultérieurement"
 
ThisWorkbook.Close False
    End If
 
 
'
' RAZ_Ouverture Macro
'
 
'
 
    Sheets("Accueil").Select
 
' indication heure et date
    CreateObject("Wscript.shell").Popup "Bonjour," & Chr$(13) & Chr$(13) & "nous sommes le " & Date & ", il est exactement " & Time & "." & Chr$(13) & Chr$(13) & "Une réinitialisation des cellules de la base de données va avoir lieu." & Chr$(13) & Chr$(13) & "Attendre le retour sur la page d'accueil avant toute manipulation.", 10, "Application développée par PC.", vbExclamation
 
 
    Call Tri_Suivi_referentiel_Documentaire
 
    Sheets("Accueil").Select
    Range("A1").Select
    ActiveSheet.Unprotect
 
    ' Opération terminée
Sheets("Accueil").Select
    CreateObject("Wscript.shell").Popup "Opération effectuée avec succès. " & Chr$(13) & "Vous pouvez travailler en toute tranquilité.", 8, "Application développée par PC.", vbInformation
 
 
   'Pour envoi mail auto 1er jour ouvré du mois
 
   With Sheets("Accueil").Range("A1")
   'Cells(Rows.Count, Columns.Count) ' adapte l'index ou le nom du sheets
        If .Value <> Month(Date) Then
            .Value = Month(Date)
            ThisWorkbook.Save
   '
   ' Sub Envoi_Mail_FP_non_analysee()
'
'
    rep = MsgBox("Création d'un @mail automatique concernant  les Fiches ouvertes dont le délai d'analyse est supérieur à 30 jours. En cas d'erreur, ne vous affolez pas, une confirmation d'envoi vous sera demandée ultérieurement.", vbYes + vbInformation, "Transmission de mail automatique...")
 
    Dim nom As String
    Dim Wbk As Workbook
    Set Wbk = Workbooks.Add
 
    With Wbk
   .Sheets(1).Name = "Envoi Mail"
   .Sheets(2).Name = "Matrice Mail"
    End With
 
    End If
    End With
 
    Windows("Base de données.xlsm").Activate
 
    Sheets("Fiche de Progres").Select
    ActiveSheet.Unprotect
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=18, Criteria1:= _
        "Ouverte"
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=21, Criteria1:= _
        "Oui"
    Range("A1:w500").Select
    Selection.Copy
    Wbk.Activate
    ActiveSheet.Paste
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("H:H").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Columns("H:I").Select
    Selection.Delete Shift:=xlToLeft
    Columns("I:I").Select
    Selection.Delete Shift:=xlToLeft
    Columns("J:J").Select
    Selection.Delete Shift:=xlToLeft
    Columns("K:K").Select
    Selection.Delete Shift:=xlToLeft
    Columns("K:K").Select
    Selection.Delete Shift:=xlToLeft
    Columns("L:M").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
 
 
    'Ligne de titre
    ActiveSheet.Unprotect
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1:k1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Rows("1:1").RowHeight = 35
    Range("A1:K1").Select
    ActiveCell.FormulaR1C1 = "Fiches non analysées depuis plus d'un mois"
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "Edition du :"
    Range("A1:K2").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    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
    Rows("3:3").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A2").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "=TODAY()"
    Range("B2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1:m1").Select
    Selection.Font.Bold = True
    Selection.Font.Size = 20
    Range("A2:B2").Select
    Selection.Font.Bold = True
    Selection.Font.Size = 10
    Range("A4:m4").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    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 = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    ActiveWindow.DisplayGridlines = False
    ActiveWindow.DisplayHeadings = False
 
 
 
    'Coupe puis colle colonnes L et M sur feuille 2
    Range("L4:L53").Select
    Selection.Cut
    Sheets("Envoi Mail").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Matrice Mail").Select
    Range("M5:M54").Select
    Selection.Cut
    Sheets("Envoi Mail").Select
    ActiveWindow.SmallScroll Down:=18
    Range("A51").Select
    ActiveSheet.Paste
 
    'Adresses des personnes en copie du mail
    Rows("3:3").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "TOTO@test.fr"
    Sheets("Matrice Mail").Select
    Range("M4").Select
    Selection.Delete
    ActiveWorkbook.Names.Add Name:="p", RefersToR1C1:="='Matrice Mail'!R1C16"
    Selection.Delete Shift:=xlToLeft
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Range("A4").Select
 
 
 
    'Boite dialogue de confirmation d envoi du mail
 
 
   Select Case MsgBox("Désirez-vous transmettre cet @mail ?", vbYesNo, "Application développée par PC.")
   Case vbYes
        'procédure si click sur Oui
   'Envoi du mail
   Dim olapp As Outlook.Application
Dim malist, Count, Envoi
Dim i
            '-------Contrôler dans Visual Basic/Outils/Références/que Microsoft Outlook --,- Object Librairy est bien coché
Sheets("Envoi Mail").Select
 
With Sheets("Envoi Mail")
 
'Suppression des adresses en doublons
Columns("A:A").Select
    Range("A19").Activate
    ActiveSheet.Range("$A$1:$A$100").RemoveDuplicates Columns:=1, Header:=xlYes
    ActiveWorkbook.Worksheets("Envoi Mail").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Envoi Mail").Sort.SortFields.Add Key:=Range( _
        "A2:A100"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Envoi Mail").Sort
        .SetRange Range("A1:A100")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWindow.SmallScroll Down:=-30
    Range("A1").Select
 
 
 
    Dim adresse(1 To 150)
                '----------------------Création de la liste d'adresses mail contenus de la ligne 2 à 151
    Set malist = Sheets("Envoi Mail").Range("A2:A151")
    Count = 1
    For Each Envoi In malist
    If Len(Envoi) Then adresse(Count) = Envoi: Count = Count + 1
    Next
                '----------------------Copie de la liste d'adresse dans une cellule vide exemple H1
    For i = 1 To 150
        If adresse(i) = "" Then Exit For
        If adresse(i) Like "*@*" Then .[H1] = .[H1] & ";" & adresse(i)
    Next i
 
    '-------adresse du répertoire ou sera enregistré le fichier
       AdresseRépertoire = ActiveWorkbook.Path
 
                '---------------------copie de la feuille à envoyer
    Application.DisplayAlerts = False
    Sheets("Matrice Mail").Copy
                '---------------------Nom du fichier à envoyer
   Fichier = ThisWorkbook.Path & "\Fiches non analysee transmis par mail le " & _
              Replace(Replace(Replace(Left(Now, 16), ":", "h"), " ", " à "), "/", "-") & ".xlsx"
 
    ActiveWorkbook.SaveAs Fichier
    ActiveWorkbook.Close
                '---------------------Envoi par mail
    Sheets("Envoi Mail").Select
    .Range("H1").Select
                '---------------------contrôle la validité ou la présence d'adresse mail en H1
    Dim msg As MailItem
    Set olapp = New Outlook.Application
    Set msg = olapp.CreateItem(olMailItem)
    msg.To = .Range("H1").Value 'Adresse de la cellule contenant la liste des adresses mails
                '--------------------Saisir le sujet de l'envoi
    msg.Subject = "Etat des Fiches dont le délai d'analyse est supérieur à 30 jours."
    '---------------------saisie du message
                '------------------- Saisir Corps du message
     msg.Body = "Mail mensuel généré automatiquement."
 
                '---------------------Adresse de la pièce jointe
     msg.Attachments.Add Source:=Fichier
    'msg.Attachments.Add Source:=ThisWorkbook.Path & "\nom fichier Excel.xlsm"
    msg.Display
    msg.Send
 
 
 
End With
 
 
   rep = MsgBox("Une copie de la pièce jointe a été transmise vers U:\Groupes fonctionnels", vbYes + vbInformation, "Transmission de mail automatique...")
 
   Select Case MsgBox("Désirez-vous fermer ce classeur ?", vbYesNo, "Application développée par PC.")
   Case vbYes
        'procédure si click sur Oui
        ActiveWindow.Close
   rep = MsgBox("Fermeture du classeur effectuée.", vbYes + vbInformation, "Sélection nouvelle requête / Application développée par PC.")
   Windows("Base de données.xlsm").Activate
    Sheets("Fiche de progres").Select
    Range("A1").Select
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=18
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=21
    Rows("1:1").Select
    Selection.AutoFilter
    Range("A1").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Range("A1").Select
    Sheets("Requetes").Select
   Case vbNo
       'procédure si click sur Non
   Windows("Base de données.xlsm").Activate
   Sheets("fiche de progres").Select
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=18
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=21
    Rows("1:1").Select
    Selection.AutoFilter
    Range("A1").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Range("A1").Select
    Sheets("Accueil").Select
    End Select
 
   Case vbNo
       'procédure si click sur Non
   ActiveWindow.Close
   rep = MsgBox("Votre courriel ne sera pas transmis. Fermeture du classeur effectuée.", vbYes + vbInformation, "Annulation transmission de courriel / Application développée par PC.")
   Windows("Base de données.xlsm").Activate
   Sheets("fiche de progres").Select
    ActiveSheet.Range("$A$1:$IS$500").AutoFilter Field:=18
    Rows("1:1").Select
    Selection.AutoFilter
    Range("A1").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Range("A1").Select
    Sheets("Requetes").Select
    End Select
 
 
 Windows("Base de données.xlsm").Activate
 Sheets("Accueil").Select
    Range("A1").Select
    ActiveSheet.Protect
 
End Sub

**Philippe Tulliez** · 22/01/2016, 17h40

Bonjour,

Aprés avoir inséré ce code a la ligne 30 de ThisWorkbook,ça bug aux lignes 10 à 13, j'ai donc remplacé par ce code :

Est-ce qu'un autre classeur ne serai pas actif par hasard.
Sauf si j'ai mal lu à aucun moment tu n'indiques ce qui ne va pas. Y a-t-il un message d'erreur et si oui lequel ?
Dire que cela bogue n'est pas très instructif, ce qui est important c'est le n° de la ligne où cela bogue (que tu as indiqué), le n° du message ainsi que son texte.

**graphikris** · 22/01/2016, 18h13

Effectivement Philippe, j'ai oublié le principal

sur le dernier code fourni dans mon post : ligne 75

Msg : impossible d'executer cette commande sur des sélections multiples

**Philippe Tulliez** · 22/01/2016, 19h07

Bonjour,
Lorsque l'on colle sur la feuille active, le collage commence à la cellule sélectionnée. Je ne dis pas que le problème vient de là mais cela vaut la peine de regarder.

Il est important d'écrire et de lire dans des cellules dont on précise la filiation complète Classeur.Feuille.PlageDeCellulesouCellule. Cela évitera ainsi également d'utiliser les méthodes Select, Activate, etc. C'est parfaitement inutile et provoque un ralentissement dans l'exécution du programme. Depuis le temps que tu es inscrite sur ce site il me semble que tu devrais le savoir.

**graphikris** · 22/01/2016, 19h18

Tu as certainement raison mais je suis nulle en Vba, je ne fais que du plagia de code jusqu'à ce que ça marche.
Sincèrement je ne comprends pas ce que tu essayes de me faire comprendre.

C'est vrai que je suis inscrite depuis 2012 mais mon vrai job n'est pas accés sur Excel. ça me sert enormement et je suis tres reconnaissante des efforts que tous les internautes ont fait pour me dépatouiller.

Et maintenant que dois vraiment faire ?

**Theze** · 23/01/2016, 09h33

Bonjour,

Quand on travaille sur différents classeurs, il est fortement conseillé d'utiliser des variables objet "WorkBook" afin de bien les identifier les uns par rapport aux autres. Il en va de même pour les feuilles !
Dans ton code tous ces "Select" "Activate" "Selection" me donne le tournis et de fait, il est assez difficile de savoir où on en est !!!
Je verrai plutôt le début de cette façon :

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
 
Sub IsReadOnly()
 
    Dim Cls_EnvoiMail As Workbook
    Dim Cls_BaseDonnees As Workbook
    Dim Fe_FicheProgres As Worksheet
 
    '##### avec ThisWorkbook on peut ne pas utiliser de variable, on sait du quel on parle ! #####
 
    If ThisWorkbook.ReadOnly Then
 
        MsgBox "Une personne du Bureau utilise déjà la base de données, vous ne pouvez pas l'ouvrir actuellement. Veuillez réessayer ultérieurement"
        ThisWorkbook.Close False
 
    End If
 
    ' RAZ_Ouverture Macro
 
    'indication heure et date
    MsgBox "Bonjour," & _
            Chr$(13) & Chr$(13) & _
            "nous sommes le " & _
            Date & _
            ", il est exactement " & _
            Time & "." & _
            Chr$(13) & Chr$(13) & _
            "Une réinitialisation des cellules de la base de données va avoir lieu." & _
            Chr$(13) & Chr$(13) & _
            "Attendre le retour sur la page d'accueil avant toute manipulation.", _
            vbExclamation, _
            "Application développée par PC."
 
 
    'Call Tri_Suivi_referentiel_Documentaire
 
    'Opération terminée
    ThisWorkbook.Worksheets("Accueil").Select
    ThisWorkbook.Worksheets("Accueil").Unprotect
 
    MsgBox "Opération effectuée avec succès. " & _
            Chr$(13) & _
            "Vous pouvez travailler en toute tranquilité.", _
            vbInformation, _
            "Application développée par PC."
 
    'mets à jour la date en A1
    With ThisWorkbook.Worksheets("Accueil").Range("A1"): If .Value <> Month(Date) Then .Value = Month(Date): End With
 
    ThisWorkbook.Save
 
    '##### mais ici, il est préférable d'utiliser une variable Objet "Workbook"... #####
 
    'ajout du nouveau classeur en y faisant référence par une variable
    Set Cls_EnvoiMail = Workbooks.Add
 
    'renommage des feuilles
    Cls_EnvoiMail.Sheets(1).Name = "Envoi Mail"
    Cls_EnvoiMail.Sheets(2).Name = "Matrice Mail"
 
    'utilisation d'une variable objet "Workbook" pour faire référence à la base de données
    Set Cls_BaseDonnees = Workbooks("Base de données.xlsm")
 
    'utilisation d'une variable objet "Worksheet" pour faire référence à la feuille "Fiche de Progres" de la base de données
    Set Fe_FicheProgres = Cls_BaseDonnees.Sheets("Fiche de Progres")
 
    With Fe_FicheProgres
 
        .Unprotect
 
        .Rows("1:1").AutoFilter
        .Range("$A$1:$IS$500").AutoFilter Field:=18, Criteria1:="Ouverte"
        .Range("$A$1:$IS$500").AutoFilter Field:=21, Criteria1:="Oui"
 
        'copie de l'un à l'autre
        .Range("A1:W500").Copy Cls_EnvoiMail.Worksheets("Envoi Mail").Range("A1")
        Application.CutCopyMode = False
 
    End With
 
    '...
    '...
    '...
    '...
    '...
    '...
 
End Sub

**graphikris** · 23/01/2016, 09h51

Merci Theze,

Effectivement je comprends mieux ton code.
C'est beaucoup plus clair.

je me met au boulot pour essayer de concevoir mon code (je pense que ça va me prendre tout le W.E), il se peut qu'en cas de doute, je revienne vers toi.

Merci.

Invité · 23/01/2016, 13h30

Bonjour graphikris,Philippes,Theze,
Pour compléter le explications de Thez, j'utiliserais une métaphore!

Il serait malvenu de planter les dents dans une tablette de chocolat avant d l'avoir complètement déballer au risque de se planter de l'aluminium dans la gencive.

L'événement Open intervient à Louverture du fichier, il n'es donc pas actif. Des select, selecton et autres activate sont impossible.
Il faut attendre l'arrêt complet de l'appareil!

L'idée de transférer le code dans un sub d'un module standard,comme le préconise Theze, est la seule méthode qui vaille.

En revanche la sub peut s'appeler de Open.

Macros combinées qui ne fonctionnent pas [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager