Excel 宏 VBA - Email 发送

Question

I am having trouble figuring out why my program is not running as intended. 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 am collecting all of the data and sending it. Any help would be greatly appreciated. I have worked with other people and they have made edits but no solutions. Due to the sensitive nature of the source data I included an image of the column header. Code to follow, thank you.

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