Sending multiple emails using data from excel cells using VBA - excel

Question

I've got a spreadsheet of clients with their client name, email address, contact and admin listed.
I want to be able to send an individual email to each client using the data from the rows that the client is listed.
I've got some VBA that I've written (parts obtained from other people) but it's trying to add all the email addresses to the to field and every other field is pulling all the data instead of the relevant row.
I'm fairly new to this VBA stuff and would greatly appreciate some help.
How can I make it draft individual emails per client with the information from just the row the client is listed.
Example data:
Column B has client names from row 3 down
Column C has email addresses from row 3 down
Column E has contact name from row 3 down
Column G has admin name from row 3 down
Here's the VBA:
Option Explicit
Sub AlexsEmailSender()
Dim OutApp As Object
Dim OutMail As Object
Dim lngLastRow As Long
Dim rngMyCell As Range
Dim objEmailTo As Object
Dim strEmailTo As String
Dim objCCTo As Object
Dim strCCTo As String
Dim objContact As Object
Dim strContact As String
Dim objAdmin As Object
Dim strAdmin As String
Dim strbody As String
Dim objClient As Object
Dim strClient As String
Dim strToday As Date
strToday = Date
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Make sure emails are unique
Set objEmailTo = CreateObject("Scripting.Dictionary")
lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
For Each rngMyCell In Worksheets("Sheet1").Range("C3:C" & lngLastRow)
If Len(rngMyCell) > 0 Then
If objEmailTo.Exists(CStr(rngMyCell)) = False Then
objEmailTo.Add CStr(rngMyCell), rngMyCell
End If
End If
Next rngMyCell
strEmailTo = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objEmailTo.Items)), ";")
'Make sure cc emails are unique
Set objCCTo = CreateObject("Scripting.Dictionary")
lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row
For Each rngMyCell In Worksheets("Sheet1").Range("D3:D" & lngLastRow)
If Len(rngMyCell) > 0 Then
If objCCTo.Exists(CStr(rngMyCell)) = False Then
objCCTo.Add CStr(rngMyCell), rngMyCell
End If
End If
Next rngMyCell
strCCTo = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objCCTo.Items)), ";")
'Make sure contacts are unique
Set objContact = CreateObject("Scripting.Dictionary")
lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row
For Each rngMyCell In Worksheets("Sheet1").Range("E3:E" & lngLastRow)
If Len(rngMyCell) > 0 Then
If objContact.Exists(CStr(rngMyCell)) = False Then
objContact.Add CStr(rngMyCell), rngMyCell
End If
End If
Next rngMyCell
strContact = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objContact.Items)), ";")
'Make sure admins are unique
Set objAdmin = CreateObject("Scripting.Dictionary")
lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "G").End(xlUp).Row
For Each rngMyCell In Worksheets("Sheet1").Range("G3:G" & lngLastRow)
If Len(rngMyCell) > 0 Then
If objAdmin.Exists(CStr(rngMyCell)) = False Then
objAdmin.Add CStr(rngMyCell), rngMyCell
End If
End If
Next rngMyCell
strAdmin = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objAdmin.Items)), ";")
'Make sure clients are unique
Set objClient = CreateObject("Scripting.Dictionary")
lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
For Each rngMyCell In Worksheets("Sheet1").Range("B3:B" & lngLastRow)
If Len(rngMyCell) > 0 Then
If objClient.Exists(CStr(rngMyCell)) = False Then
objClient.Add CStr(rngMyCell), rngMyCell
End If
End If
Next rngMyCell
strClient = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objClient.Items)), ";")
Application.ScreenUpdating = True
strbody = "Dear " & strContact & "," & vbNewLine & vbNewLine & _
"Say Hello World!" & vbNewLine & vbNewLine & _
"Kind Regards," & vbNewLine & _
"Mr A Nother"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = strEmailTo
.CC = strCCTo
.BCC = ""
.Subject = strToday & " - Agreement"
.Body = strbody
'.Attachments.Add
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Answer 1

To Answer Your Question:
I think the reason you are only seeing one email is because you only created one OutMail object. If you want to loop, you need to set the object = nothing before you can create a new one:
Set OutMail = Nothing
It also looks like you are creating a single dictionary that has all of the emails pushed together in the email field, the names pushed together, etc. You need a way to loop through each email you want to send. You could create an array of dictionaries, create a collection of objects, or loop through a range where the data is kept. Looping through a range sounds like it would be the least complicated in this case.
The pseudocode/code looks like this:
'instantiate the outlook object. Use:
Set OutApp = CreateObject("Outlook.Application")
'Create your array of dictionaries or return a range with the data
'Let's call it listOfEmails
For each email in listOfEmails:
'instantiate the mail object. Use:
Set OutMail = OutApp.CreateItem(0)
'The block that creates the email:
With OutMail
.To = strEmailTo
.CC = strCCTo
.BCC = ""
.Subject = strToday & " - Agreement"
.Body = strbody
'.Attachments.Add
.Display
End With
'destroy the object when you are done with that particular email
Set OutMail = Nothing
Next email
Set OutApp = Nothing
Some General Advice:
Breaking your code into smaller pieces can help make things easier to fix and read. It also makes it more reusable for both this project and future projects.
I'm including this feedback because it also makes for easier questions to answer on here.
For example:
A function to check if Outlook is open:
Function isOutlookOpen() As Boolean
'returns true or false if Outlook is open
Dim OutApp As Object
On Error Resume Next
Set OutApp = CreateObject("Outlook.Application")
If OutApp Is Nothing Then
isOutlookOpen = False
Else: isOutlookOpen = True
End If
On Error GoTo 0
End Function
A subroutine to send the email that you can call from another sub:
Sub sendEmail(ByVal recTO As String, ByVal subjectContent As String, ByVal bodyContent As String)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = recTO
'.CC = ""
'.BCC = ""
.subject = subjectContent
.body = bodyContent '.HTMLBody
.display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
A function to return a range of data:
Function dataRange() As Range
'Returns the range where the data is kept
Dim ws As Worksheet
Dim dataRng As Range
Dim lastRow As Integer
Dim rng As Range
Set ws = Workbooks("outlookEmail.xlsm").Sheets("dataSheetName")
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
'still select where the data should go if the data range is empty
If lastRow = 2 Then
lastRow = lastRow + 1
End If
Set dataRange = Range("B3", "G" & lastRow)
End Function
A subroutine to bring it all together:
Sub main()
'This sub does more than one thing, but I'm asuming it's extremely custom ans still relatively short
Dim data As Range
Dim subj As String
Dim recEmail As String
Dim body As String
Dim Row As Range
'check if data exists. Exit the sub if there's nothing
Set data = dataRange
If dataRange.Cells(1, 1).Value = "" Then
MsgBox "Data is empty"
Exit Sub
End If
'Loop through the data and send the email.
For Each Row In data.Rows
'Row is still a range object, so you can access the ranges inside of it like you normally would
recEmail = Row.Cells(1, 2).Value
If recEmail <> "" Then 'if the email is not blank, send the email
subj = Format(Date, "mm.dd.yy") & " - Agreement"
body = "Dear " & Row.Cells(1, 4).Value & "," & vbNewLine & vbNewLine & _
"Say Hello World!" & vbNewLine & vbNewLine & _
"Kind Regards," & vbNewLine & _
"Mr A Nother"
Call sendEmail(recEmail, subj, body)
End If
Next Row
End Sub
Very Importantly:
Thank you to Ron De Bruin for teaching me all about sending emails from Outlook using code in Excel VBA

Answer 2

First of all, add
Option Explicit
above all code.
Then correct the errors.
Then:
https://stackoverflow.com/help/mcve

Answer 3

You want to use Excel VBA to achieve Outlook mail delivery?
if so, You can use the following method to get the email address in range.
You can not be so troublesome. You have simpler code to implement.
Sub Send_Email()
Dim rng As Range
For Each rng In Range("C1:C4")
Call mymacro(rng)
Next rng
End Sub
Private Sub mymacro(rng As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim MailBody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
MailBody = "hello"
On Error Resume Next
With OutMail
.To = rng.Value
.CC = ""
.BCC = ""
.Subject = Sheet1.Cells(rng.Row, 1).Value
.Body = Sheet1.Cells(rng.Row, 2).Value
.Display
'.Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
I use the mymacro method to create a message and send it.
I loop through the email addresses("C1:C4").And call mymacro method to send an email to this address.