#StackBounty: #excel #vba Using VBA to build emails from Excel that combine email body when addresses duplicate

Bounty: 100

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

Set OutApp = Nothing
Application.DisplayAlerts = False
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") & 

'Copy the range and create a new workbook to past the data in
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
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    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, _
    .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
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

Get this bounty!!!