Boucle qui se stoppe sans explication

**JFV__** · 21/03/2017, 12h09

Bonjour,

J'ai une macro qui envoie des mails sous Outlook mais qui se stop sans que je sache pourquoi (sans message d'erreur)...

Dans une colonne C j'ai l'adresse de l'agent (X agents) dans la colonne D l'adresse du responsable (Y responsables). X et Y=3 dans l'exemple du fichier joint soit 3 mails à envoyer..
Dans cet exemple 1 seul mail s'affiche et la macro se stop sans message d'erreur.

Mes données étant confidentielles j'ai mis un exemple mais "dans la vraie vie" je peux avoir entre 50 à 500 mails à envoyer d'un coup et si la boucle se stop, difficile de s'assurer que tous les mails ont bien été envoyés...et même se les "taper" à la main un par un...pas top

Par exemple j'avais 72 lignes et l'envoi des mails se stoppait à la ligne 40...

Du coup quelqu'un peut-il me dire pourquoi cela ne marche pas? J'ai modifié à plusieurs reprises mon code mais cela ne marche pas.

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
Sub Lancer_le_Mailing()
 
Dim liste_Resp As Range
Dim infos As String
Dim infos2 As String
Dim infos3 As String
Dim RESP As String
Dim liste_Agent
 
Dernligne = Range("B" & Rows.Count).End(xlUp).Row
Range("A3").Select
ActiveCell.FormulaR1C1 = "=IF(RC[1]="""","""",R[-1]C)"
    Range("A3").AutoFill Destination:=Range("A3:A" & Dernligne)
 
Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
 
 Range("A2:D2").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("Mailing").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Mailing").Sort.SortFields.Add Key:=Range("C3:C" & Dernligne _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Mailing").Sort.SortFields.Add Key:=Range("B3:B" & Dernligne _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Mailing").Sort
        .SetRange Range("A2:D" & Dernligne)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
Range("Z:Z").Cells.ClearContents
Set liste_Agent = Range([c3], [c65536].End(xlUp))
[c:c].AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Range("Z2").Select
    ActiveCell.FormulaR1C1 = "Liste Adresse @mail Agent"
    Range("Z2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
liste_Agent.Copy ([Z3])
Set liste_Resp = Range([Z3], [Z65536].End(xlUp))
Columns("Z:Z").EntireColumn.AutoFit
 
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
 
For Each cell In liste_Resp.Cells
 
For Each cell2 In liste_Agent.Cells
If cell2 = cell Then
If InStr(1, RESP, cell2.Offset(, 1)) = 0 Then RESP = RESP & ";" & cell2.Offset(, 1)
infos = cell2.Offset(, -2) & " " & cell2.Offset(, -1) & infos
infos2 = cell2.Offset(, -2) & " " & cell2.Offset(, -1) & Chr(10) & infos2
infos3 = cell2.Offset(, 2)
End If
Next
 
infos = Left(infos, Len(infos))
infos2 = Left(infos2, Len(infos2))
 
Dim outapp As Object, outmail As Object
Dim dest As String
 
Set outapp = CreateObject("Outlook.Application")
outapp.Session.Logon
Set outmail = outapp.CreateItem(0)
 
With outmail
 
.Importance = 2
.SentOnBehalfOfName = "adresseX@mail.fr"
.To = cell
.cc = RESP
.Subject = "ObjetX" & " " & infos3
.HTMLBody = "<HTML><body><FONT COLOR=RED><b><u>Merci d'utiliser UNIQUEMENT la touche : REPONDRE A TOUS pour répondre à ce message</FONT></b></u><p><p>" _
& "Bonjour,<p><p>" _
& "Blablabla"
.Display
 
End With
 
infos = ""
infos2 = ""
infos3 = ""
RESP = ""
Next
 
End Sub

Boucle qui se stoppe sans explication [XL-2010]

Macros et VBA Excel

Mode arborescent

Discussions similaires

Partager

Partager