VBA按E列筛选分开发送邮件 收件人重复且无法插入表格到正文

更新VBA代码实现批量发邮件功能时，遇到两个问题：

• 无法将筛选后的对应表格粘贴到邮件正文中
• 收件人存在重复添加的情况

以E列数据作为筛选依据：

• 为E列每一个不同取值单独发送一封邮件
• 邮件正文粘贴对应筛选结果的表格内容
• 收件人取自对应分组J列的邮箱地址

原有代码 #

Sub SendMultipleEmailsaa()
    
    Dim Mail_Object, OutApp As Object
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim arr() As Variant
    
    LastRow = ws.Cells(ws.Rows.Count, "b").End(xlUp).Row
    
    arr = ws.Range("E2:E" & LastRow)
    
    Set Mail_Object = CreateObject("Outlook.Application")
    
    first = 2
    
    For i = LBound(arr) To UBound(arr)
    
        If i = UBound(arr) Then GoTo YO
        If arr(i + 1, 1) = arr(i, 1) Then
            first = WorksheetFunction.Min(first, i + 1)
        Else
    YO:
            Set OutApp = Mail_Object.CreateItem(0)
    
            With OutApp
                .Subject = "Your Details"
                .Body = "Please find details below"
                .Display
                .To = ws.Range("J" & i + 1).Value
                For j = first To i
                    .Recipients.Add ws.Range("J" & j).Value
                Next
                first = i + 2
    
            End With
        End If
    
    Next
    
End Sub

1. 分组行号计算逻辑错误，边界判断混乱，导致同组收件人重复添加、分组拆分错误
2. 仅使用纯文本Body属性，没有实现筛选表格复制、粘贴到邮件正文的逻辑
3. 未对同组内重复邮箱做去重判断
4. 未提前对E列排序，若同值行不连续会被拆分为多封邮件

Sub SendMultipleEmailsaa()
    Dim Mail_Object As Object, OutApp As Object
    Dim ws As Worksheet
    Dim LastRow As Long, i As Long, j As Long, endRow As Long
    Dim currentVal As String, email As String
    Dim emailDict As Object
    Dim dataRng As Range
    
    Set ws = ActiveSheet
    ' 用字典做邮箱去重
    Set emailDict = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    
    ' 获取最后一行数据，先按E列排序保证同组数据连续
    LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Set dataRng = ws.Range("A1:J" & LastRow) ' 可根据实际表格列数修改范围
    dataRng.Sort Key1:=ws.Range("E1"), Header:=xlYes
    
    Set Mail_Object = CreateObject("Outlook.Application")
    i = 2
    
    Do While i <= LastRow
        currentVal = ws.Cells(i, "E").Value
        ' 定位当前分组的结束行
        endRow = i
        Do While endRow < LastRow And ws.Cells(endRow + 1, "E").Value = currentVal
            endRow = endRow + 1
        Loop
        
        ' 收集当前分组所有不重复邮箱
        emailDict.RemoveAll
        For j = i To endRow
            email = Trim(ws.Cells(j, "J").Value)
            If email <> "" And Not emailDict.Exists(email) Then
                emailDict.Add email, ""
            End If
        Next
        
        ' 筛选当前分组数据
        If ws.FilterMode Then ws.ShowAllData
        dataRng.AutoFilter Field:=5, Criteria1:=currentVal
        ' 复制筛选后的可见区域（含表头）
        dataRng.SpecialCells(xlCellTypeVisible).Copy
        
        ' 创建邮件
        Set OutApp = Mail_Object.CreateItem(0)
        With OutApp
            .Subject = "Your Details - " & currentVal
            .To = Join(emailDict.Keys, ";")
            .Display
            ' 写入正文前缀后粘贴表格，保留原Excel格式
            .HtmlBody = "<p>Please find details below:</p>" & .HtmlBody
            .GetInspector.WordEditor.Content.Paste
            ' 确认内容无误后可把上面的.Display替换为.Send直接发送
        End With
        
        ' 进入下一分组
        i = endRow + 1
    Loop
    
    ' 恢复表格初始状态
    ws.ShowAllData
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    ' 释放对象
    Set OutApp = Nothing
    Set Mail_Object = Nothing
    Set emailDict = Nothing
End Sub

• 如果表格列数不是A-J列，修改代码中dataRng对应的范围即可
• 脚本默认弹出邮件窗口供内容核对，不需要人工确认的话，将.Display替换为.Send即可自动发送
• 粘贴到邮件的表格会保留Excel中设置的单元格格式，不需要额外调整HTML样式
• 同分组下重复的邮箱地址会自动去重，不会出现重复收件人问题

内容的提问来源于stack exchange，提问作者khyati dedhia