Collect dynamic number of rows for each recipient - excel

Question

Once the macro begins, it runs all line items in the spreadsheet instead of the ones I specified.
The purpose of the program is to send emails to the correct person and append any additional rows with their name.
For each unique email I want to collect all of the data.
The issue is that the email contents are dynamic and the body of the email includes a chart with appended row items for each recipient. The spreadsheet contains more than one row for each recipient.
Due to the sensitive nature of the source data I included an image of the column headers.
Option Explicit
Sub Send()
Dim rEmailAddr As Range, rCell As Range, rNext As Range
Dim NmeRow As Long, x As Long
Dim MailTo As String, MailSubject As String, MailBody As String, AddRow As String, tableHdr As String, MsgStr As String
Dim OutApp As Object, OutMail As Object
Dim CurrentEmail As String, LastEmail As String
If OutApp Is Nothing Then
'Outlook is not opened, so open
Set OutApp = CreateObject("Outlook.Application")
End If
'Set email address as range for first loop to run down
Set rEmailAddr = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
'MailSubject does not change, so only needs to be created once
MailSubject = "Action and Response Requested - Reserve Review for Claim(s)"
'Get a row count to clear column AM at the end
x = rEmailAddr.Rows.Count
'Create the html table and header from the first row
tableHdr = "<table border=1><tr><th>" & Range("G1").Value & "</th>" _
& "<th>" & Range("H1").Value & "</th>" _
& "<th>" & Range("I1").Value & "</th>" _
& "<th>" & Range("J1").Value & "</th>" _
& "<th>" & Range("K1").Value & "</th>" _
& "<th>" & Range("L1").Value & "</th>" _
& "<th>" & Range("M1").Value & "</th>" _
& "<th>" & Range("N1").Value & "</th>" _
& "<th>" & Range("O1").Value & "</th>" _
& "<th>" & Range("P1").Value & "</th>" _
& "<th>" & Range("T1").Value & "</th>" _
& "<th>" & Range("U1").Value & "</th>" _
& "<th>" & Range("V1").Value & "</th>" _
& "<th>" & Range("W1").Value & "</th>" _
& "<th>" & Range("X1").Value & "</th>" _
& "<th>" & Range("Y1").Value & "</th>" _
& "<th>" & Range("Z1").Value & "</th>" _
& "<th>" & Range("AA1").Value & "</th>" _
& "<th>" & Range("AB1").Value & "</th>" _
& "<th>" & Range("AC1").Value & "</th>" _
& "<th>" & Range("AD1").Value & "</th>" _
'Check to see if column Q = 'yes' and skip mail if it does
CurrentEmail = ""
LastEmail = ""
For Each rCell In rEmailAddr
CurrentEmail = Replace(rCell.Value, " ", "")
If ((rCell.Value <> "") And CurrentEmail <> LastEmail) Then
NmeRow = rCell.Row
MailTo = rCell.Value 'column D
'Create MailBody table row for first row
MailBody = "<tr>" _
& "<td>" & (rCell.Offset(0, 3).Value) & "</td>" _
& "<td>" & (rCell.Offset(0, 4).Value) & "</td>" _
& "<td>" & (rCell.Offset(0, 5).Value) & "</td>" _
& "<td>" & (rCell.Offset(0, 6).Value) & "</td>" _
& "<td>" & (rCell.Offset(0, 7).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 8).Value) & "</td>" _
& "<td>" & (rCell.Offset(0, 9).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 10).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 11).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 12).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 16).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 17).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 18).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 19).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 20).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 21).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 22).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 23).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 24).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 25).Value) & "</td>" _
& "<td>" & CStr(rCell.Offset(0, 26).Value) & "</td>" _
& "</tr>"
'Second loop checks the email addresses of all cells following the current cell in the first loop.
'Yes will be appended on any duplicate finds and another row added to the mailbody table
For Each rNext In rEmailAddr.Offset(NmeRow - 1, 0).Resize(x - NmeRow) 'process to last row only
If Replace(rNext.Value, " ", "") = Replace(rCell.Value, " ", "") Then
'Create additional table row for each extra row found"
AddRow = "<tr>" _
& "<td>" & CStr(rNext.Offset(0, 3).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 4).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 5).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 6).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 7).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 8).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 9).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 10).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 11).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 12).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 16).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 17).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 18).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 19).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 20).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 21).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 22).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 23).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 24).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 25).Value) & "</td>" _
& "<td>" & CStr(rNext.Offset(0, 26).Value) & "</td>" _
& "</tr>"
MailBody = MailBody & AddRow
End If
'Clear additional table row variable ready for next
Next rNext
'Create email
Set OutMail = OutApp.createitem(0)
With OutMail
.to = Replace(MailTo, " ", "")
.Subject = MailSubject
.HTMLBody = tableHdr & MailBody & "</table>"
.Display
End With
LastEmail = Replace(rCell.Value, " ", "")
End If
Next rCell
End Sub

Answer 1

Use a dictionary (using email address as key) to group the rows for each email with a single pass down the sheet. Then loop through the dictionary keys creating each email from the rows number held as a comma separated list in the dictionary value.
Option Explicit
Sub Send()
Dim OutApp As Object, OutMail As Object
Dim sEmailAddr As String, tableHdr As String
Dim MailTo As String, Mailbody As String, MailSubject As String
Dim wb As Workbook, ws As Worksheet
Dim lastRow As Long, n As Long, i As Long
Dim k, v, arData
Dim dict As Object, fso As Object, ts As Object
Set dict = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
Set ws = wb.Sheets(1) ' change to suit
' put data into an array
With ws
lastRow = .Range("D" & Rows.Count).End(xlUp).Row
arData = .Range("A1:AD" & lastRow)
End With
' compile list of rows for each address using dictionary
' key = address, value = comma separated list of rows
For i = 2 To UBound(arData)
sEmailAddr = Trim(arData(i, 4)) ' col D
sEmailAddr = Replace(sEmailAddr, " ", "")
' build list of rows for each email address
If dict.exists(sEmailAddr) Then
dict(sEmailAddr) = dict(sEmailAddr) & "," & i
Else
dict.Add sEmailAddr, i
End If
Next
'Create the html table and header from the first row
'G - P, T - AD
tableHdr = "<table border=""1"" cellspacing=""0"" cellpadding=""3""><tr>"
For n = 7 To 30
Select Case n
Case 7 To 16, 20 To 30
tableHdr = tableHdr & "<th>" & arData(1, n) & "</th>"
End Select
Next
tableHdr = tableHdr & "</tr>" & vbCr
'If OutApp Is Nothing Then
'Outlook is not opened, so open
' Set OutApp = CreateObject("Outlook.Application")
'End If
'MailSubject does not change, so only needs to be created once
MailSubject = "Action and Response Requested - Reserve Review for Claim(s)"
' send emails
For Each k In dict.keys
MailTo = k
MailBody = ""
' loop through rows for this email
For Each v In Split(dict(k), ",")
Mailbody = Mailbody & "<tr>" & vbCr
For n = 7 To 30
Select Case n
Case 7 To 11, 13
Mailbody = Mailbody & "<td>" & arData(v, n) & "</td>"
Case 12, 14 To 16, 20 To 30
Mailbody = Mailbody & "<td>" & CStr(arData(v, n)) & "</td>"
End Select
Next
Mailbody = Mailbody & "</tr>" & vbCr
Next
' dump text to file to check without outlook
Set ts = fso.createTextFile(wb.Path & "\" & MailTo & ".html", True)
ts.writeLine "To : " & MailTo & "<br/>"
ts.writeLine "Subject: " & MailSubject & "<br/>"
ts.write tableHdr & Mailbody & "</table>"
ts.Close
'Create email
'Set OutMail = OutApp.createitem(0)
'With OutMail
' .To = Replace(MailTo, " ", "")
' .Subject = MailSubject
' .HTMLBody = tableHdr & Mailbody & "</table>"
' .Display
'End With
Next
MsgBox dict.Count & " emails sent"
End Sub