Sending multiple emails using data from excel cells using VBA

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

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.

Answer 2

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 3

First of all, add

Option Explicit

above all code. Then correct the errors. Then: https://stackoverflow.com/help/mcve