Using VBA to build emails from Excel that combine email body when addresses duplicate

Question

First off, I'm very new with VBA. Still learning so I may be making some obvious mistakes.

I'm trying to build emails using an Excel spreadsheet that I'm pulling information from to populate To, Subject, and Body of the emails. These are going to sales people to review information for their customers. I need each email to be based on the customer and sent to the corresponding sales reps. Some customers have multiple lines of information where as others have one and some sales people have overlapping customers.

The code I have found and have been trying to edit is (as far as I can tell) building the emails based on the email addresses. So I end up with an email that has a sales person in the To line and the body has all of the customers specifically for that sales person. Meanwhile the subject line is only pulling the one customer the email is meant to display.

Any help on this would be a godsend. I'm trying to reduce a 4-6 hour workload down to sub 1hr.

Any time I try to make changes to the code to base it on the customer rather than the email address I either end up breaking the code or not building an email and instead somehow just applying a filter to the spreadsheet that filters for the same information that was going into the email prior to the change.

I feel there may be more info necessary because I'm finding this to be far more complex than it appears but that may be me overthinking things. I've tried to limit this post to just the pertinent info but if I need to provide more I certainly will. I've been wracking my brain on this for weeks.

I have tried a variety of If And/Then statements to try and make the code look at the customer column rather than the email column but I can't find any combination that works. The code I posted below is what I have managed to get to work to some degree. Since I've tried so many variations I wouldn't know what would be the best mistake to include. So hopefully this is at least not too messy.

*Edit: The code requires a column of names in Column A which, as far as I understood, was supposed to be the condition that 'for this name create email using address in Column B.' But what it seems to be doing is creating an email using the address in Column B as the condition. So any customer line in A that matches the address in B gets thrown into the same email. I sort of need that to be the other way around. One email per customer of Column A to what ever email addresses are listed in Column B.

Edit2: Source info looking something like this:

+----------------+---------------------+---------+--------------+
|     Customer   |       Email         | Subj Ln |  Email Body  |
+----------------+---------------------+---------+--------------+
| Customer 1     | sales1@address.com  | info    |     info     |
| Customer 2     | sales2@address.com  | info    |     info     |
| Customer 2     | sales2@address.com  | info    |     info     |
| Customer 2     | sales2@address.com  | info    |     info     |
| Customer 3     | sales2@address.com  | info    |     info     |
| Customer 4     | sales3@address.com  | info    |     info     |
| Customer 4     | sales3@address.com  | info    |     info     |
| Customer 5     | sales1@address.com  | info    |     info     |
| Customer 6     | sales4@address.com  | info    |     info     |
+----------------+---------------------+---------+--------------+

So the code should be looking at the Customer Column (Column A) and looking for unique instances then generating an email with the appropriate email address in the Email Column (Column B). Each one should be a separate email and when the email addresses are unique to the customer it will do that. So, in the example above Customer 6 gets a singular email to sales4. The email generates the appropriate Subject Line and Email Body. However, Customer 1 will generate an email with the appropriate Subj Ln and Email Body (for Customer 1) and it will also have the appropriate sales1 email address. But since sales1 also has Customer 5, the Email Body information for Customer 5 is included in the Customer 1 email. When I need Customer 5 to be a separate email.

Edit3: I added the following paragraph as a comment below because I wasn't sure which would be the best way to get visibility to it.

I have been playing around with the code some more and think I may have found something that I didn't fully understand before. I'm not sure if I still do but I think I have a better understanding. -- It looks like the code is creating a filter that it uses to build the body of the email. It's filtering Column B (emails) for unique values and creating an email based on that. I think if I can change that filter code to filter for Column A and build an email using Column B, then I think I'll get what I'm looking for. I just can't figure out how to make that work.

I hope I'm clear. It is getting very confusing and overwhelming to me but I hope it is making sense. Also, I hope my formatting is correct.

Sub Send_Row_Or_Rows_2()

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:AY" & Ash.Rows.Count)
FieldNum = 2    'Filter column = B because the filter range start in 
column A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=Cws.Range("A1"), _
        CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
    For Rnum = 2 To Rcount

        'Filter the FilterRange on the FieldNum column
        FilterRange.AutoFilter Field:=FieldNum, _
                               Criteria1:=Cws.Cells(Rnum, 1).Value

        'If the unique value is a mail addres create a mail
        If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

            With Ash.AutoFilter.Range
                On Error Resume Next
                Set rng = .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With

            Set OutMail = OutApp.CreateItem(0)

            On Error Resume Next
            With OutMail
                .To = Cws.Cells(Rnum, 1).Value
                .Subject = Ash.Cells(Rnum, 3) & " Bond Review " & Date
                .HTMLBody = RangetoHTML(rng)
                .Display  'Or use Send
            End With
            On Error GoTo 0

            Set OutMail = Nothing
        End If

        'Close AutoFilter
        Ash.AutoFilterMode = False

    Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Function RangetoHTML(rng As Range)

Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & 
".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
     SourceType:=xlSourceRange, _
     Filename:=TempFile, _
     Sheet:=TempWB.Sheets(1).Name, _
     Source:=TempWB.Sheets(1).UsedRange.Address, _
     HtmlType:=xlHtmlStatic)
    .Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                      "align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

Public Function EOMonth(dInput As Date)

LastDayOfMonth = DateSerial(Year(dInput()), Month(dInput() + 1), -1)

End Function

Answer 1

If I understand correctly, you want send emails based upon a unique combination of Customer and Email Address, and for each unique combo get the corresponding subject line and email body. So in your example above, I am assuming that since customer2 and Customer4 are duplicates, then you only want to send one email for each customer and use the corresponding subject line and email body found at the first occurrence of the Cutomer2 or 4.

If my assumptions are correct, then the code below should do the job. Note the comments that explain each step.

Edit: I forgot to mention that using delimiter as I did originally is risky, because that delimiter could exist somewhere in the data and splitting by that delimiter would throw off your results. So, the better method, (and I believe more clean as well), would be the following:

Option Explicit

Public Sub SendEmails()

 Dim objDict As Object
 Dim objWB As Workbook
 Dim objWS As Worksheet
 Dim rngToLookUp As Range
 Dim lngLastRow As Long, i As Long
 Dim arryEmailData As Variant
 Dim objOutlookApp As Object, objOutlookEmail As Object
 Dim varKey As Variant, arryTemp As Variant

    Application.ScreenUpdating = False

    Set objWB = Workbooks("SomeWBName")
    Set objWS = objWB.Worksheets("SomeWSName")
    lngLastRow = objWS.Cells(objWS.Rows.Count, "A").End(xlUp).Row   'Find last row with data
    Set rngToLookUp = objWS.Range("A2:D" & lngLastRow)              'set range for last row of data

    arryEmailData = rngToLookUp.Value2    'Get the email data from the sheet into an array

        Set objDict = CreateObject("Scripting.Dictionary")      'set the dicitonary object
        Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object


            For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)
                varKey = Join(Array(arryEmailData(i, 1), arryEmailData(i, 2)), "|") 'Concatenate columns A and B using '|' as a
                                                                                    'delimiter to form a unique Key

                If Not objDict.Exists(varKey) Then

                    objDict(varKey) = Array(arryEmailData(i, 2), _
                                            arryEmailData(i, 3), _
                                            arryEmailData(i, 4))
                End If

                varKey = Empty

            Next i

            'for each unique key in the dicitonary
            'get the corresponding item which is an array
            'created in the loop above
            On Error GoTo cleanup
            For Each varKey In objDict.Keys
                arryTemp = objDict.Item(varKey)
                Set objOutlookEmail = objOutlookApp.CreateItem(0)
                    With objOutlookEmail
                        .To = arryTemp(0)
                        .Subject = arryTemp(1)
                        .Body = arryTemp(2)
                        .Send
                    End With
                Set objOutlookEmail = Nothing
                arryTemp = Empty
            Next

    MsgBox "All Emails have been sent", vbInformation

cleanup:
        Set objOutlookApp = Nothing
        Application.ScreenUpdating = True

End Sub

Original Post:

Option Explicit

Public Sub SendEmails()

 Dim objDict As Object
 Dim objWB As Workbook
 Dim objWS As Worksheet
 Dim rngToLookUp As Range
 Dim lngLastRow As Long, i As Long
 Dim arryEmailData As Variant
 Dim objOutlookApp As Object, objOutlookEmail As Object
 Dim varKey As Variant, arryTemp As Variant

    Application.ScreenUpdating = False

    Set objWB = Workbooks("SomeWBName")
    Set objWS = objWB.Worksheets("SomeWSName")
    lngLastRow = objWS.Cells(objWS.Rows.Count, "A").End(xlUp).Row   'Find last row with data
    Set rngToLookUp = objWS.Range("A2:D" & lngLastRow)              'set range for last row of data

    arryEmailData = rngToLookUp.Value2    'Get the email data from the sheet into an array

        Set objDict = CreateObject("Scripting.Dictionary")      'set the dicitonary object
        Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object


            For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)
                varKey = Join(Array(arryEmailData(i, 1), arryEmailData(i, 2)), "|") 'Concatenate columns A and B using '|' as a
                                                                                    'delimiter to form a unique Key

                If Not objDict.Exists(varKey) Then                          'If the key doesn't already exist, then concatenate
                                                                            'the corresponding Email Address, subject line,
                                                                            'and email body using
                                                                            ''|' as a delimiter
                    objDict(varKey) = Join(Array(arryEmailData(i, 2), _
                                                 arryEmailData(i, 3), _
                                                 arryEmailData(i, 4)), "|")
                End If

                varKey = Empty

            Next i

            'for each unique key in the dicitonary
            'get the corresponding item
            'split the item into a 3 element array using '|' delimiter that
            'was originally used to concatenate the item in the loop above
            On Error GoTo cleanup
            For Each varKey In objDict.Keys
                arryTemp = Split(objDict.Item, "|")
                Set objOutlookEmail = objOutlookApp.CreateItem(0)
                    With objOutlookEmail
                        .To = arryTemp(0)
                        .Subject = arryTemp(1)
                        .Body = arryTemp(2)
                        .Send
                    End With
                Set objOutlookEmail = Nothing
            Next

    MsgBox "All Emails have been sent", vbInformation

cleanup:
        Set objOutlookApp = Nothing
        Application.ScreenUpdating = True

End Sub

Answer 2

I using like that, First you need to convert your text to table and name it CustomersTbl or use

LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' get last row
Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 4))

instead of

Set rng = ws.Range("CustomersTbl")

Here is a code

Sub Send_Row_Or_Rows_2()
' reference Microsoft Scripting Runtime
Dim OutApp As Object, OutMail As Object, dict As Object
Dim tKey(0 To 3, 0 To 1) As Variant
Dim rng As Range
Dim ws As Worksheet

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
    .EnableEvents = False ' speedup Application, disable events
    .ScreenUpdating = False ' prevent flashing, disable screen
End With

Set ws = ThisWorkbook.Worksheets("Sheet1") ' set shortest variable for worksheet
Set dict = CreateObject("Scripting.Dictionary") ' set object for unique values
Set rng = ws.Range("CustomersTbl") ' get range to variable
'LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' get last row
'Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 4)) 'get range to variable
For Each cRow In rng ' create unique dictionary
    i = i + 1 ' increment
    strCustomer = rng(i, 1)
    strEmail = rng(i, 2)
    strSubj = rng(i, 3)
    strBody = rng(i, 4)
    If dict.Exists(strCustomer) Then ' if dublicate
        Dim tempArr() As Variant
            tempArr() = dict(strCustomer)
                If UBound(tempArr, 2) > 0 Then ' if not nothing
                    If Not IsEmpty(tempArr(0, 1)) Then ' if second element empty
                        sCount = UBound(tempArr, 2) + 1
                    Else
                        sCount = UBound(tempArr, 2)  ' as is empty array
                    End If
                End If
                    ReDim Preserve tempArr(0 To 3, 0 To sCount) ' redim array to next array size
                        tempArr(0, sCount) = strCustomer 'fill array element
                        tempArr(1, sCount) = strEmail 'fill array element
                        tempArr(2, sCount) = strSubj 'fill array element
                        tempArr(3, sCount) = strBody 'fill array element
            dict(strCustomer) = tempArr ' put array to dictionary by unique name
    Else
        tKey(0, 0) = strCustomer 'fill array element
        tKey(1, 0) = strEmail 'fill array element
        tKey(2, 0) = strSubj 'fill array element
        tKey(3, 0) = strBody 'fill array element
            dict.Add strCustomer, tKey ' create unique name
    End If
Next cRow ' loop next row
' now dict contains only unique elements, lets loop throught them
For Each UniqueCustomer In dict ' for each unique element
countEmails = UBound(dict(UniqueCustomer), 2) ' count emails of unique group
    For i = 0 To countEmails ' loop each email in group
        strCustomer = dict(UniqueCustomer)(0, i)
        strEmail = dict(UniqueCustomer)(1, i)
        strSubj = dict(UniqueCustomer)(2, i)
        strBody = dict(UniqueCustomer)(3, i)
        If Not IsEmpty(strCustomer) Then ' if element not empty create email
            Set OutMail = OutApp.CreateItem(0)
                    On Error Resume Next
                    With OutMail
                        .To = strEmail
                        .Subject = strSubj
                        .HTMLBody = strBody
                        .Display  'Or use Send
                    End With
                    On Error GoTo 0
            Set OutMail = Nothing
        Else
            GoTo sNext
        End If
        Stop
sNext:
    Next I ' next email
Next UniqueCustomer 'next unique

cleanup:
Set OutApp = Nothing

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Answer 3

I've written code like this quite a few times - the base template is actually on my github

The code:

Option Explicit


Sub LoopOverData()
Dim STbl As ListObject
Dim LastRow As Long
Dim WB As Workbook
Dim i As Long
Dim WS As Worksheet
Dim tblwsname As String


    Set WB = ThisWorkbook


    tblwsname = WB.Names("TblWSName").RefersToRange.Value2
    Set WS = WB.Sheets(tblwsname)
    Set STbl = WS.ListObjects("EmailDataTable")


    LastRow = STbl.ListRows.Count


    For i = 1 To LastRow
         WB.Names("IterationNumber").RefersToRange.Value2 = i
         Application.Calculate
         Call CreateEmail
    Next i



End Sub





Sub CreateEmail()
' This macro is for the pricing confirm e-mail
    Dim outApp As New Outlook.Application
    Dim OutMail As Object
    Dim Attchmnt As String
    Dim Signature As String
    Dim WB As Workbook
    Set WB = ThisWorkbook
   Attchmnt = WB.Names("Attachment").RefersToRange.Value2
   'We keep the file path for the attachment we're sending in Excel, for easy editing. Look in name manager to find it.

    Application.EnableEvents = False
     Application.ScreenUpdating = False

    ' We don't need the screen to flicker while the macro is running - it speeds things up.
    Set OutMail = outApp.CreateItem(0)
    'Signature = OutMail.Body
    On Error Resume Next
    With OutMail
    .To = WB.Names("to").RefersToRange.Value2
   .CC = WB.Names("cc").RefersToRange.Value2
   .BCC = WB.Names("bcc").RefersToRange.Value2
   .Subject = WB.Names("Subject").RefersToRange.Value2
   .Body = WB.Names("Body").RefersToRange.Value2
   .display
   End With

   If Attchmnt = "" Then
   Else
   OutMail.Attachments.Add Attchmnt
   End If

   'OutMail.send
   'Remove this comment to directly send. Not recommended.

   On Error GoTo 0
End Sub

The setup: You create a "sample email" basically, and you use =index(Range, IndexNum) to determine what item you're currently working on. IndexNum is a named range back to the base index, which the code will be changing.

Hence, as each number in the index gets moved, all of the formulas update to the new email that needs to be written. It then calls the email generating procedure, and creates (but doesn't send) the email needed. This is to give you a chance to review the emails before sending them.

You'll want the Microsoft Outlook 16.0 Object library enabled.

There might be some rule to sending the information that I'm missing - if that's the case, I recommend a few formulas or power query to do the compression

Answer 4

Try this, actually it generate needed number of emails. If OK, I'll clear the code

Option Explicit

Sub Send_Row_Or_Rows_2()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer


    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    'Set filter sheet, you can also use Sheets("MySheet")
    Set Ash = ActiveSheet

    'Set filter range and filter column (column with e-mail addresses)
    Set FilterRange = Ash.Range("A1:BY" & Ash.Rows.Count)
    FieldNum = 2    'Filter column = B because the filter range start in     Column A
    'FieldNum = 2

    Columns("A:B").Select
    Selection.Copy

    ActiveSheet.Paste

    'Add a worksheet for the unique list and copy the unique list in A1
    Set Cws = Worksheets.Add
    ActiveSheet.Paste
'    FilterRange.Columns(FieldNum).AdvancedFilter _
'            Action:=xlFilterCopy, _
'            CopyToRange:=Cws.Range("A:B"), _
'            CriteriaRange:="", Unique:=True


    Columns("A:B").Select
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$B$10").RemoveDuplicates Columns:=Array(1, 2), Header _
        :=xlYes

    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount

            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=1, _
                                   Criteria1:=Cws.Cells(Rnum, 1).Value

            FilterRange.AutoFilter Field:=2, _
                                   Criteria1:=Cws.Cells(Rnum, 2).Value

            'If the unique value is a mail addres create a mail
            If Cws.Cells(Rnum, 2).Value Like "?*@?*.?*" Then

                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With

                Set OutMail = OutApp.CreateItem(0)

                On Error Resume Next
                With OutMail
                    Debug.Print "to: " & .to & " subj: " & .Subject & " body:" & .htmlbody
                    .to = Cws.Cells(Rnum, 2).Value
                    .Subject = Ash.Cells(Rnum, 3) & " Bond Review " & Date
                    .htmlbody = RangetoHTML(rng)
                    .Display  'Or use Send
                End With
                On Error GoTo 0

                Set OutMail = Nothing
            End If

            'Close AutoFilter
            Ash.AutoFilterMode = False

        Next Rnum
    End If

cleanup:
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Cws.Delete
    Application.DisplayAlerts = True

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Function RangetoHTML(rng As Range)

Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
     SourceType:=xlSourceRange, _
     Filename:=TempFile, _
     Sheet:=TempWB.Sheets(1).Name, _
     Source:=TempWB.Sheets(1).UsedRange.Address, _
     HtmlType:=xlHtmlStatic)
    .Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                      "align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

Public Function EOMonth(dInput As Date)

LastDayOfMonth = DateSerial(Year(dInput()), Month(dInput() + 1), -1)

End Function