Découpage puis envoi de mail, erreur '-2147352571 (80020005)

**halaster08** · 08/07/2014, 16h31

J'ai un problème avec le code suivant, qui à partir d'un gros fichier excel, crée puis envoie 162 petits fichiers, au bout d'envirion 30 itération (entre 28 et 32 suivant d'où je commence) j'obtient l'erreur suivante: erreur d'execution '-2147352571 (80020005)' Type incorrect, quand il essaye de rentrer le destinataire du mail.
Je ne comprends pas cette erreur, surtout qu'elle n'intervient pas toujours à la même itération, et que je peut continuer la macro après l'erreur sans rien corriger, et que l'itération fautive s'exécute sans problème si on la lance seule.
Bref si qqn pouvait m'aider, ce serait formidable.

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
Sub decoupage_et_mail()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With 'pour ne pas avoir de message d'alertes (confirmation a chaque suppression d'onglets / écrasement de fichier existant ...)
' attention pour les phases de test il vaut mieux ne pas le mettre
 
Dim ObjOutlook As New Outlook.Application
Dim oBjMail
Dim Nom_Fichier As String
Dim i As Integer
Dim t As Integer
Dim a As Integer
'declaration des variables
 
Windows("Cotations vérif_Final.xlsm").Activate
Range("A1:K13708").Select
    ActiveWorkbook.Worksheets("Fiche travail").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Fiche travail").Sort.SortFields.Add Key:=Range( _
        "A2:A13708"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Fiche travail").Sort
        .SetRange Range("A1:K13708")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'Tri du fichier par rapport a la première colonne (ici nom de l'agence)
Chemin = ActiveWorkbook.Path
 
i = 2
t = i
' deux compteur pour le découpage, t pour le début et i pour la fin
a = 0
' compteur pour le nom d'itération (ici on sait qu'on a 162 agences)
 
Do While a < 162
 
t = i 'debut de la zone de découpage
nom = Cells(t, 1) ' on récupère le nom de l'agence
 
Do While Cells(i, 1) = Cells(i + 1, 1) 'tant que l'agence de ne change pas
i = i + 1 'on incrémente le compteur
Loop
 
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Chemin & "\" & nom & ".xlsx"
'on crée et renomme un fichier excel au nom de l'agence
 
Sheets("Feuil2").Select
    ActiveWindow.SelectedSheets.Delete
    Application.ScreenUpdating = True
Sheets("Feuil3").Select
    ActiveWindow.SelectedSheets.Delete
    Application.ScreenUpdating = True
'on supprime les feuilles inutiles
 
Windows("Cotations vérif_Final.xlsm").Activate
Range(Cells(1, 1), Cells(1, 8)).Select
Selection.Copy
Windows(nom & ".xlsx").Activate
Range("A1").Select
ActiveSheet.Paste
'copie des en-têtes
Windows("Cotations vérif_Final.xlsm").Activate
Range(Cells(t, 1), Cells(i, 8)).Select
Selection.Copy
Windows(nom & ".xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
'copie des donnée entre les lignes t et i
ActiveWorkbook.Save
ActiveWorkbook.Close
 
Windows("Cotations vérif_Final.xlsm").Activate 'envoi du mail
 Set ObjOutlook = New Outlook.Application
    Set oBjMail = ObjOutlook.CreateItem(olMailItem)
    With oBjMail
        .To = Cells(t, 9) ' le destinataire
       .Subject = Cells(t, 10) ' l'objet du mail
       .Body = Cells(t, 11) 'le corps du mail ..son contenu
       .Attachments.Add Chemin & "\" & nom & ".xlsx" '"C:\Data\essai.txt" ' ou Nomfichier
       .Display
  SendKeys "^{ENTER}" 'pour éviter la confirmation par outlook
    End With
 
 
i = i + 1
a = a + 1
Loop
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'réactivation des alertes
 
End Sub

**Mr Poulpe** · 09/07/2014, 11h04

Bonjour,

J'imagine que ça va un peu trop vite pour outlook.

Essaie peut être de rajouter un doevents comme ça :

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
Sub decoupage_et_mail()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With 'pour ne pas avoir de message d'alertes (confirmation a chaque suppression d'onglets / écrasement de fichier existant ...)
' attention pour les phases de test il vaut mieux ne pas le mettre
 
Dim ObjOutlook As New Outlook.Application
Dim oBjMail
Dim Nom_Fichier As String
Dim i As Integer
Dim t As Integer
Dim a As Integer
'declaration des variables
 
Windows("Cotations vérif_Final.xlsm").Activate
Range("A1:K13708").Select
    ActiveWorkbook.Worksheets("Fiche travail").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Fiche travail").Sort.SortFields.Add Key:=Range( _
        "A2:A13708"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Fiche travail").Sort
        .SetRange Range("A1:K13708")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'Tri du fichier par rapport a la première colonne (ici nom de l'agence)
Chemin = ActiveWorkbook.Path
 
i = 2
t = i
' deux compteur pour le découpage, t pour le début et i pour la fin
a = 0
' compteur pour le nom d'itération (ici on sait qu'on a 162 agences)
 
Do While a < 162
 
t = i 'debut de la zone de découpage
nom = Cells(t, 1) ' on récupère le nom de l'agence
 
Do While Cells(i, 1) = Cells(i + 1, 1) 'tant que l'agence de ne change pas
i = i + 1 'on incrémente le compteur
Loop
 
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Chemin & "\" & nom & ".xlsx"
'on crée et renomme un fichier excel au nom de l'agence
 
Sheets("Feuil2").Select
    ActiveWindow.SelectedSheets.Delete
    Application.ScreenUpdating = True
Sheets("Feuil3").Select
    ActiveWindow.SelectedSheets.Delete
    Application.ScreenUpdating = True
'on supprime les feuilles inutiles
 
Windows("Cotations vérif_Final.xlsm").Activate
Range(Cells(1, 1), Cells(1, 8)).Select
Selection.Copy
Windows(nom & ".xlsx").Activate
Range("A1").Select
ActiveSheet.Paste
'copie des en-têtes
Windows("Cotations vérif_Final.xlsm").Activate
Range(Cells(t, 1), Cells(i, 8)).Select
Selection.Copy
Windows(nom & ".xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
'copie des donnée entre les lignes t et i
ActiveWorkbook.Save
ActiveWorkbook.Close
 
Windows("Cotations vérif_Final.xlsm").Activate 'envoi du mail
 Set ObjOutlook = New Outlook.Application
    Set oBjMail = ObjOutlook.CreateItem(olMailItem)
    With oBjMail
        .To = Cells(t, 9) ' le destinataire
       .Subject = Cells(t, 10) ' l'objet du mail
       .Body = Cells(t, 11) 'le corps du mail ..son contenu
       .Attachments.Add Chemin & "\" & nom & ".xlsx" '"C:\Data\essai.txt" ' ou Nomfichier
       .Display
        SendKeys "^{ENTER}" 'pour éviter la confirmation par outlook
        DoEvents
    End With
 
 
i = i + 1
a = a + 1
Loop
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'réactivation des alertes
 
End Sub

Poulpe

**halaster08** · 11/07/2014, 10h13

Merci Mr Poulpe, problème résolu

Découpage puis envoi de mail, erreur '-2147352571 (80020005) [XL-2010]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager