VBA宏优化需求：将同一收件人的多发票合并为单封邮件发送

这个需求很贴合实际场景，核心思路就是先按收件人编号把对应发票分组，再为每组用户发送单封带所有对应附件的邮件，替代原来逐行发邮件的逻辑。下面是具体的实现方案：

核心逻辑拆解 #

• 用字典（Dictionary）做分组容器：键是提取后的用户编号（比如从2_3803063里拆分出3803063），值是该用户对应的所有发票附件路径集合。
• 遍历可见行时，只筛选条件为1的行，将其按用户编号归类到字典中。
• 最后遍历字典的每个键，为每个用户生成一封邮件，批量添加所有对应附件。

修改后的代码示例 #

假设原表格中，收件人编号在某一列（比如单元格偏移量为6的列），发票路径在偏移量为7的列，你可以根据实际表格结构调整这些数值：

Sub SendGroupedInvoiceEmails()
    Dim wsA As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim userDict As Object
    Dim userID As String
    Dim invoicePath As String
    Dim outlookApp As Object
    Dim outlookMail As Object
    
    ' 初始化工作表对象（替换成你的实际工作表名称）
    Set wsA = ThisWorkbook.Worksheets("发票清单")
    lastRow = wsA.Cells(wsA.Rows.Count, "A").End(xlUp).Row
    ' 创建字典用于分组用户和发票
    Set userDict = CreateObject("Scripting.Dictionary")
    ' 初始化Outlook对象
    Set outlookApp = CreateObject("Outlook.Application")
    
    ' 第一步：遍历可见行，按用户编号分组收集发票路径
    For Each cell In wsA.Range("A3:A" & lastRow).SpecialCells(xlCellTypeVisible)
        ' 仅处理条件值为"1"的行
        If cell.Offset(0, 5).Value = "1" Then
            ' 拆分用户编号（从"2_3803063"格式中提取后半段）
            userID = Split(cell.Offset(0, 6).Value, "_")(1)
            ' 获取当前行的发票路径
            invoicePath = cell.Offset(0, 7).Value
            
            ' 将发票路径添加到对应用户的集合中
            If userDict.Exists(userID) Then
                ' 用|作为分隔符拼接多个路径
                userDict(userID) = userDict(userID) & "|" & invoicePath
            Else
                userDict(userID) = invoicePath
            End If
        End If
    Next cell
    
    ' 第二步：遍历字典，为每个用户发送合并邮件
    For Each userID In userDict.Keys
        Set outlookMail = outlookApp.CreateItem(0)
        ' 拆分当前用户的所有发票路径
        Dim invoicePaths As Variant
        invoicePaths = Split(userDict(userID), "|")
        
        With outlookMail
            ' 这里需要根据userID匹配对应邮箱，比如从表格中查找或用映射字典
            .To = GetUserEmail(userID) 
            .Subject = "您的发票汇总 - 用户ID：" & userID
            .Body = "您好，以下是您的全部发票附件，请查收。"
            
            ' 批量添加附件，同时检查文件是否存在
            Dim singlePath As Variant
            For Each singlePath In invoicePaths
                If Dir(singlePath) <> "" Then
                    .Attachments.Add singlePath
                End If
            Next singlePath
            
            '.Display ' 调试时用Display预览，正式发送换成.Send
            .Send
        End With
        
        Set outlookMail = Nothing
    Next userID
    
    ' 释放对象
    Set outlookApp = Nothing
    Set userDict = Nothing
    MsgBox "批量邮件发送完成！"
End Sub

' 辅助函数：根据userID获取对应邮箱（你可以根据实际逻辑修改）
Function GetUserEmail(userID As String) As String
    ' 示例：从工作表的某列匹配userID和邮箱
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("用户信息")
    Dim matchCell As Range
    Set matchCell = ws.Range("A:A").Find(userID, LookIn:=xlValues, LookAt:=xlWhole)
    If Not matchCell Is Nothing Then
        GetUserEmail = matchCell.Offset(0, 1).Value
    Else
        GetUserEmail = "默认邮箱@example.com"
    End If
End Function

关键细节说明 #

1. 用户编号拆分：用Split函数按_分割字符串，取索引1的元素（因为2_3803063分割后是数组("2","3803063")），如果你的编号格式不同，需要调整拆分逻辑。
2. 邮箱匹配：我写了一个辅助函数GetUserEmail，你可以根据实际情况修改——比如从用户信息表中查找，或者直接用字典映射userID和邮箱。
3. 文件存在校验：添加附件前用Dir(singlePath)判断文件是否存在，避免因路径错误导致邮件发送失败。
4. 可见行兼容：保留了原代码的SpecialCells(xlCellTypeVisible)，确保只处理筛选后的可见行。

这个方案能大幅减少邮件发送数量，同时让用户收到汇总的发票附件，既提升效率又优化用户体验。

内容的提问来源于stack exchange，提问作者Filip Ondo