VBA宏异常：无法按指定收件人动态收集对应行数据

问题说明 #

编写的VBA宏原本意图是：为电子表格中每个唯一收件人汇总其所有相关行数据，生成包含对应表格的邮件发送给收件人。但实际运行时，宏会错误处理所有行项目，无法正确按收件人分组汇总，且未实现“列Q值为yes则跳过发送”的逻辑。

核心错误分析 #

• 循环范围计算错误：原代码中第二个循环的范围rEmailAddr.Offset(NmeRow - 1, 0).Resize(x - NmeRow)逻辑错误，无法正确遍历当前收件人的后续关联行。
• 缺失列Q判断逻辑：代码注释提到要检查列Q是否为"yes"并跳过，但实际未加入该判断逻辑。
• 重复处理风险：仅通过LastEmail判断是否已处理收件人，若收件人邮箱顺序不连续，会出现重复发送或漏发问题。

修正后的代码 #

Option Explicit
Sub SendClaimsEmails()
    Dim rEmailAddr As Range, rCell As Range
    Dim lastRow As Long, currentRow As Long
    Dim MailTo As String, MailSubject As String, MailBody As String, tableHdr As String
    Dim OutApp As Object, OutMail As Object
    Dim processedEmails As Collection
    
    ' 初始化Outlook应用：优先获取已打开的实例，失败则新建
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
    
    ' 获取D列有效数据范围（从第2行开始）
    lastRow = Cells(Rows.Count, "D").End(xlUp).Row
    Set rEmailAddr = Range("D2:D" & lastRow)
    
    ' 固定邮件主题
    MailSubject = "Action and Response Requested - Reserve Review for Claim(s)"
    
    ' 构建HTML表格表头（补全闭合标签）
    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></tr>"
    
    ' 存储已处理的邮箱，避免重复发送
    Set processedEmails = New Collection
    
    ' 遍历每个邮箱行
    For Each rCell In rEmailAddr
        MailTo = Trim(rCell.Value)
        ' 跳过空邮箱、已处理邮箱，以及列Q为"yes"的行
        If MailTo <> "" And Not IsInCollection(processedEmails, MailTo) Then
            If UCase(Trim(rCell.Offset(0, 13).Value)) <> "YES" Then
                ' 初始化当前收件人的邮件表格内容
                MailBody = GetTableRow(rCell)
                
                ' 遍历后续所有行，收集同一收件人的有效数据
                For currentRow = rCell.Row + 1 To lastRow
                    If Trim(Cells(currentRow, "D").Value) = MailTo Then
                        ' 跳过列Q为"yes"的行
                        If UCase(Trim(Cells(currentRow, "Q").Value)) <> "YES" Then
                            MailBody = MailBody & GetTableRow(Cells(currentRow, "D"))
                        End If
                    End If
                Next currentRow
                
                ' 创建并显示邮件（测试用，需直接发送可改为.Send）
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                     .To = MailTo
                     .Subject = MailSubject
                     .HTMLBody = tableHdr & MailBody & "</table>"
                     .Display
                End With
                
                ' 标记该邮箱已处理
                processedEmails.Add MailTo, Key:=MailTo
            End If
        End If
    Next rCell
    
    ' 释放对象资源
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set processedEmails = Nothing
End Sub

' 辅助函数：判断值是否已在集合中
Function IsInCollection(col As Collection, val As String) As Boolean
    Dim item As Variant
    On Error Resume Next
    item = col(val)
    IsInCollection = (Err.Number = 0)
    On Error GoTo 0
End Function

' 辅助函数：生成单条数据的HTML表格行
Function GetTableRow(r As Range) As String
    GetTableRow = "<tr>" _
        & "<td>" & CStr(r.Offset(0, 3).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 4).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 5).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 6).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 7).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 8).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 9).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 10).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 11).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 12).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 16).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 17).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 18).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 19).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 20).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 21).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 22).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 23).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 24).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 25).Value) & "</td>" _
        & "<td>" & CStr(r.Offset(0, 26).Value) & "</td></tr>"
End Function

关键修改点 #

• 新增已处理邮箱集合：用Collection存储已发送的邮箱，彻底避免重复发送，不受邮箱顺序影响。
• 修复循环范围逻辑：直接按行号遍历后续行，准确匹配同一收件人的所有关联数据。
• 补全列Q判断逻辑：加入判断，若列Q值为"yes"则跳过该行，不纳入邮件表格。
• 拆分辅助函数：将生成表格行的逻辑拆分为独立函数，简化代码维护；新增集合判断函数，提升可读性。
• 修复HTML结构：补全原代码缺失的表头闭合标签，确保邮件HTML格式合法。
• 优化Outlook初始化：优先复用已打开的Outlook实例，提升运行效率。

内容的提问来源于stack exchange，提问作者S.H.