#StackBounty: #excel #vba Using VBA to build emails from Excel that combine email body when addresses duplicate
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 | email@example.com | info | info | | Customer 2 | firstname.lastname@example.org | info | info | | Customer 2 | email@example.com | info | info | | Customer 2 | firstname.lastname@example.org | info | info | | Customer 3 | email@example.com | info | info | | Customer 4 | firstname.lastname@example.org | info | info | | Customer 4 | email@example.com | info | info | | Customer 5 | firstname.lastname@example.org | info | info | | Customer 6 | email@example.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