I have a macro to send out batches of emails to clients, using personalized info for each client. It's been working great, but it's just been brought to my attention that the macro doesn't send or display emails after about the 20th draft that populates in Outlook when you run the macro.
So any advice or insight on why I can't send more than 20 emails at once when the macro should run through the last row of information, please let me know.
Sub Mail()
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(oMailItem)
Dim strMailBody As String
Dim Cel As Range
For Each Cel In Sheets("MS_Data").Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
If Cel.Offset(0, 8).Value = "y" Then ' "Y" or "y" - Case sensitive
Set objEmail = objOutlook.CreateItem(oMailItem)
StrMailSubject = ThisWorkbook.Sheets("Mail_Details").Range("A2").Text
strMailBody = "<BODY style='font-size:11pt;font-family:Calibri(Body)'>" & ThisWorkbook.Sheets("Mail_Details").Range("B2").Text & "</BODY>"
strMailBody = Replace(strMailBody, Chr(10), "<br>")
strFolder = "C:\Users\x\OneDrive - x\Desktop\AL TEST"
strISO = Cel.Offset(0, 1).Value
strSalutation = Cel.Offset(0, 2).Value
strEmail = Cel.Offset(0, 3).Value
strCC = Cel.Offset(0, 4).Value
strfile = Cel.Offset(0, 5).Value
strfile2 = Cel.Offset(0, 6).Value
strfile3 = Cel.Offset(0, 7).Value
'
StrMailSubject = Replace(StrMailSubject, "<ISO>", strISO)
strMailBody = Replace(strMailBody, "<Salutation>", strSalutation)
With objEmail
.To = CStr(strEmail)
.CC = CStr(strCC)
.Subject = StrMailSubject
.BodyFormat = olFormatHTML
.Display
If strfile <> "" Then
.Attachments.Add strFolder & "\" & strfile
End If
If strfile2 <> "" Then
.Attachments.Add strFolder & "\" & strfile2
End If
If strfile3 <> "" Then
.Attachments.Add strFolder & "\" & strfile3
End If
.HTMLBody = strMailBody & .HTMLBody
End With
End If
Next Cel
MsgBox "All the mails have been displayed successfully"
End Sub
So any advice or insight on why I can't send more than 20 emails at once when the macro should run through the last row of information, please let me know.
Sub Mail()
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(oMailItem)
Dim strMailBody As String
Dim Cel As Range
For Each Cel In Sheets("MS_Data").Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
If Cel.Offset(0, 8).Value = "y" Then ' "Y" or "y" - Case sensitive
Set objEmail = objOutlook.CreateItem(oMailItem)
StrMailSubject = ThisWorkbook.Sheets("Mail_Details").Range("A2").Text
strMailBody = "<BODY style='font-size:11pt;font-family:Calibri(Body)'>" & ThisWorkbook.Sheets("Mail_Details").Range("B2").Text & "</BODY>"
strMailBody = Replace(strMailBody, Chr(10), "<br>")
strFolder = "C:\Users\x\OneDrive - x\Desktop\AL TEST"
strISO = Cel.Offset(0, 1).Value
strSalutation = Cel.Offset(0, 2).Value
strEmail = Cel.Offset(0, 3).Value
strCC = Cel.Offset(0, 4).Value
strfile = Cel.Offset(0, 5).Value
strfile2 = Cel.Offset(0, 6).Value
strfile3 = Cel.Offset(0, 7).Value
'
StrMailSubject = Replace(StrMailSubject, "<ISO>", strISO)
strMailBody = Replace(strMailBody, "<Salutation>", strSalutation)
With objEmail
.To = CStr(strEmail)
.CC = CStr(strCC)
.Subject = StrMailSubject
.BodyFormat = olFormatHTML
.Display
If strfile <> "" Then
.Attachments.Add strFolder & "\" & strfile
End If
If strfile2 <> "" Then
.Attachments.Add strFolder & "\" & strfile2
End If
If strfile3 <> "" Then
.Attachments.Add strFolder & "\" & strfile3
End If
.HTMLBody = strMailBody & .HTMLBody
End With
End If
Next Cel
MsgBox "All the mails have been displayed successfully"
End Sub
