VBA Outlook宏实现同收件人同部门附件合并单封发送

业务表结构 #

业务数据表字段对应列规则：

• B列：邮箱地址
• C列：文件名前6位匹配关键字
• J列：部门/属地（Directorate or Place）
• N列：目标文件存储路径

原有逻辑与问题 #

原宏运行逻辑：遍历指定目录路径，按C列文件名前6位匹配查找目标文件，未找到对应文件则不创建邮件。
存在问题：同一收件人同部门对应多份报告时会生成多封独立邮件，数据表共约300行，存在大量重复收件人条目，冗余邮件多、发送效率低。

优化规则 #

提前对数据表排序适配分组逻辑：排序后若相邻行的B列（邮箱地址）、J列（部门/属地）取值完全一致，则将新匹配到的文件添加到已创建的同封邮件中，无需重复新建邮件，实现同收件人同部门的附件归集到单封邮件发送。原代码中标注「TESTING」的测试代码片段可直接删除。

原有VBA代码 #

Sub MailerMACRO()
    
Application.ScreenUpdating = False
    
Set rng = Worksheets("STATIC COPY OF DIST").Range("N3:N7")  'This is where folder paths are
For Each cell In rng 'For each cell in the above range
    Dim SendAccount As String 'reference the email address as text
    Dim CostCentre As String ' reference the first 6 digits of the file name as text
    Dim Directz As String
    Dim Namez As String
    
    Namez = Split(cell.Offset(0, -13).Value, " ")(0) ' Just take the first name of the individual for email
    CostCentre = cell.Offset(0, -11).Value '(look 11 columns to the left of column N, AKA column C)
    Directz = StrConv((cell.Offset(0, -4).Value), vbProperCase) 'Change the directorate name from block capitals to proper case
       
    Path = cell.Value 'What is the file path from ccell in column N
    If Path <> "" Then ' If its not blank, then what
 
        EmailAdd = cell.Offset(0, -12).Value 'Get the email from column B, 12 columns to the left of column N
        ClientFile = Dir(Path & CostCentre & "*.*") 'Look into the file path and search using the first 6 digits shown as 'Cust Digits'
    
        If ClientFile = "" Then GoTo DisBit 'If there's no staff list then skip to the end.
        'TESTING THIS AGAIN
       ' If cell.Offset(-1, -12).Value = EmailAdd And StrConv((cell.Offset(-1, -4).Value), vbProperCase) = Directo Then GoTo Chicago
        'TESTING THIS AGAIN
         
        Set OutApp = CreateObject("Outlook.Application") 'Email setup via outlook
        Set OutMail = OutApp.CreateItem(o)
        With OutMail
            .Subject = Range("B1").Value & " - " & Directz & " - Staff Lists" 'value in cell B1 and "Staff Lists" as a formulae
            .to = EmailAdd
            .SentOnBehalfOfName = "nth-tr.financialmanagement@nhs.net" ' Send via FM mailbox.
            .Body = "Hi " & Namez & "," & vbNewLine & vbNewLine & "Please find attached your Staff Lists to accompany your Monthly Financial Statements/Reports." & vbNewLine & vbNewLine & "Kind Regards," & vbNewLine & vbNewLine & "Financial Management Team" ' & .Body
            .Display
            
'TESTING THIS ELEMENT
'Chicago:
            Do While ClientFile <> ""
                If Len(ClientFile) > 0 Then
                    AttachFile = Path & ClientFile
                    .Attachments.Add (AttachFile)
                End If
                ClientFile = Dir
            Loop
        
        End With
    End If
DisBit:
Next

Application.ScreenUpdating = True
End Sub

优化后可用代码 #

Sub MailerMACRO()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("STATIC COPY OF DIST")
    ' 按实际数据行数修改遍历范围，示例覆盖300行数据
    Set rng = ws.Range("N3:N302")
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lastEmail As String, lastDirect As String
    
    ' 仅创建一次Outlook实例，减少资源占用
    Set OutApp = CreateObject("Outlook.Application")
    
    For Each cell In rng
        Dim CostCentre As String, Directz As String, Namez As String
        Dim Path As String, EmailAdd As String, ClientFile As String, AttachFile As String
        
        ' 跳过空路径行
        Path = cell.Value
        If Path = "" Then GoTo DisBit
        
        ' 读取当前行字段
        Namez = Split(cell.Offset(0, -13).Value, " ")(0)
        CostCentre = cell.Offset(0, -11).Value
        Directz = StrConv(cell.Offset(0, -4).Value, vbProperCase)
        EmailAdd = cell.Offset(0, -12).Value
        
        ' 查找当前行匹配的文件
        ClientFile = Dir(Path & CostCentre & "*.*")
        If ClientFile = "" Then GoTo DisBit
        
        ' 与上一分组比对，不同则新建邮件
        If EmailAdd <> lastEmail Or Directz <> lastDirect Then
            ' 释放上一邮件对象
            If Not OutMail Is Nothing Then
                Set OutMail = Nothing
            End If
            ' 新建邮件并配置基础信息
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .Subject = ws.Range("B1").Value & " - " & Directz & " - Staff Lists"
                .to = EmailAdd
                .SentOnBehalfOfName = "nth-tr.financialmanagement@nhs.net"
                .Body = "Hi " & Namez & "," & vbNewLine & vbNewLine & _
                        "Please find attached your Staff Lists to accompany your Monthly Financial Statements/Reports." & _
                        vbNewLine & vbNewLine & "Kind Regards," & vbNewLine & vbNewLine & "Financial Management Team"
                .Display
            End With
            ' 更新分组标记
            lastEmail = EmailAdd
            lastDirect = Directz
        End If
        
        ' 向当前邮件追加所有匹配到的附件
        Do While ClientFile <> ""
            AttachFile = Path & ClientFile
            OutMail.Attachments.Add AttachFile
            ClientFile = Dir
        Loop
        
DisBit:
    Next cell
    
    ' 释放对象
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

使用注意事项

1. 运行宏前必须先对数据表排序：以B列邮箱地址为第一关键字、J列部门/属地为第二关键字排序，保证同组数据相邻
2. 代码中ws.Range("N3:N302")需按实际数据的最后一行行号修改，避免漏遍历或遍历空行
3. 测试阶段保留.Display会逐封弹窗显示邮件供核对，确认内容无误后可将.Display改为.Send实现自动发送

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