Setting up a mass distribution email list from Excel - excel

Question

This should be straight-forward but I somehow can't get it right. I am trying to set-up an automatic email blast from Excel. I have followed step by step the instructions from other posts here, with no success. This is a dummy example I've created, for the sake of simplicity.
I would like to:
send emails to everybody in the list
conditionally replace certain keywords in the body
populate a column with the delivery status for each email (sent/failed)
My current code sends the email only to the first person in the list. I've used my personal email address for testing purposes. I wonder if sending the emails to the same address could be the issue. If anybody can provide some guidance, would be much appreciated!
Sub SendMail()
Dim EmailSent, EmailFailed, i As Integer
Dim StatusSent, StatusFailed As String
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
EmailSent = 0
EmailFailed = 0
StatusFailed = "failed"
StatusSent = "sent"
i = 1
Do
DoEvents
With olMail
.To = Cells(i, 1).Value
.Subject = "test"
.CC = ""
.BCC = ""
.Importance = olImportanceHigh
.BodyFormat = olFormatHTML
.HTMLBody = Cells(i, 2).Value
If Cells(i, 3) = 1 Then
.HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 4))
Else
.HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 5))
End If
.send
End With
On Error Resume Next
olMail.send
If Err Then
EmailFailed = EmailFailed + 1
ActiveSheet.Cells(i, 6).Value = StatusFailed 'change status from pending to failed
Else
EmailSent = EmailSent + 1
ActiveSheet.Cells(i, 6).Value = StatusSent 'change status from pending to sent
End If
i = i + 1
Loop Until i = Range(Range("A1"), Range("A1").End(xlDown)).Count
If EmailSent = 0 Then
MsgBox Prompt:="Emails could not be sent"
Else
MsgBox Prompt:="Sent emails: " & EmailSent & vbNewLine _
& "Failed emails: " & EmailFailed
End If
On Error GoTo 0
Set olApp = Nothing
Set olMail = Nothing
End Sub

Answer 1

You're missing two crucial lines in your Do loop:
Set olMail = olApp.CreateItem(olMailItem)
and at the end:
Set olMail = Nothing
Try this instead:
Sub SendMail()
Dim EmailSent, EmailFailed, i As Integer
Dim StatusSent, StatusFailed As String
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
EmailSent = 0
EmailFailed = 0
StatusFailed = "failed"
StatusSent = "sent"
i = 1
Do
DoEvents
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.To = Cells(i, 1).Value
.Subject = "test"
.CC = ""
.BCC = ""
.Importance = olImportanceHigh
.BodyFormat = olFormatHTML
.HTMLBody = Cells(i, 2).Value
If Cells(i, 3) = 1 Then
.HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 4))
Else
.HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 5))
End If
.send
End With
On Error Resume Next
olMail.send
If Err Then
EmailFailed = EmailFailed + 1
ActiveSheet.Cells(i, 6).Value = StatusFailed 'change status from pending to failed
Else
EmailSent = EmailSent + 1
ActiveSheet.Cells(i, 6).Value = StatusSent 'change status from pending to sent
End If
Set olMail = Nothing
i = i + 1
Loop Until i = Range(Range("A1"), Range("A1").End(xlDown)).Count
If EmailSent = 0 Then
MsgBox Prompt:="Emails could not be sent"
Else
MsgBox Prompt:="Sent emails: " & EmailSent & vbNewLine _
& "Failed emails: " & EmailFailed
End If
On Error GoTo 0
Set olApp = Nothing
End Sub