Create Email from Excel Using a Loop to Go Through Rows

[learningVBA321]

I have a sheet from which I loop through each row and create an email for each row. Attachments are based on the Division name. Currently, it creates an email for every row, so if one person under Name has, say 8 divisions, they will receive 8 emails, each with a different attachment. I want to have it loop and if if finds the same Name, then create one email for that Name, with all their Division reports attached. It would then move on to the next row, or skip the row if it was a dupe name/address to the row above it. In this example, I would want it to create one email to the Name Sample Sample1, with attachments for Widgets and Doorknobs. Then for the rest, they would each get their usual one email. The below code works except I cannot figure out the correct way to get it to continue looping. It works as intended unless it hits another set of dupe names, at which point it will create a single email with the first row's attachment, and then goes and creates the next email with both attachments for that same name. I just need to get this to skip the rows correctly in my loop, so it does not create that 'in-between' email with only one attachment. It works for the first two in this sheet, but then if there were a Sample2 followed by another Sample2, it creates the extra 'in-between' email before creating the email with both attachments. Thanks Cross-posted here: https://stackoverflow.com/questions/47685381/create-email-from-excel-using-a-loop-to-go-through-rows <code>Sub SendMail() Dim OutApp As Object Dim OutMail As Object Dim cell As Range Dim strdir As String Dim strFilename As String Dim sigString As String Dim strBody As String Dim strName As Variant Dim strName1 As Variant Dim strDept As Variant Dim strName2 As String Dim strName3 As Variant Dim strName4 As String Dim strName5 As Variant Application.ScreenUpdating = False Set OutApp = CreateObject("Outlook.Application") sigString = Environ("appdata") & _ "\Microsoft\Signatures\Test.htm" If Dir(sigString) <> "" Then signature = GetBoiler(sigString) Else signature = "" End If strdir = "z:\" strBody = "[FONT=calibri]Please review the attached report for your department." For Each person In Range("b2:b9").Cells.SpecialCells(xlCellTypeConstants) Set strName = person.Offset(0, -1) Set strName1 = person.Offset(0, 2) Set strName3 = person.Offset(1, 0) Set strDept = person.Offset(1, 2) Set strName5 = person.Offset(1, -1) If person = strName3 Then Set OutMail = OutApp.CreateItem(0) With OutMail strFilename = Dir("z:\" & strName1 & "*") strFilename1 = Dir("z:\" & strDept & "*") strName2 = Left(strName, InStr(strName & " ", " ") - 1) .To = person.Value .Subject = "Monthly Report for " & strName1 .HTMLBody = "[FONT=calibri]" & "Dear " & strName2 & ", " & signature .Attachments.Add strdir & strFilename .Attachments.Add strdir & strFilename1 .Display 'Or use Send End With Else: person = person.Offset(1, 0) Set OutMail = OutApp.CreateItem(0) With OutMail strFilename1 = Dir("z:\" & strDept & "*") strName4 = Left(strName5, InStr(strName & " ", " ") - 1) .To = strName3 .Subject = "Monthly Report for " & strDept .HTMLBody = "[FONT=calibri]" & "Dear " & strName4 & ", " & signature .Attachments.Add strdir & strFilename1 .Display 'Or use Send End With End If Next person End Sub Function GetBoiler(ByVal sFile As String) As String Dim fso As Object Dim ts As Object Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2) GetBoiler = ts.ReadAll ts.Close End Function[/FONT][/FONT][/FONT]</code>[FONT=calibri][FONT=calibri][FONT=calibri] [/FONT][/FONT][/FONT]

<tbody>
</tbody>

 

[learningVBA321]

I tried to do this with a dictionary but could not get the arguments to add in, just to give an idea of options I have tried.

 

[learningVBA321]

12 views, noone has any thoughts?

 

[learningVBA321]

So anyone? Still stuck on this.

 

[learningVBA321]

Noone has any ideas?