如何发送带多附件的邮件且避免重复发送给同一收件人

针对你的需求：表格A列是唯一ID（避免同一收件人重复收信），B列存收件人邮箱，D、E列是对应附件，需要生成与A列最大ID数一致的邮件，每封邮件包含对应ID下的所有附件，修改后的VBA代码如下：

Sub 按ID生成邮件()
    Dim ws As Worksheet
    Dim dict As Object
    Dim cell As Range
    Dim outlookApp As Object, mailItem As Object
    Dim id As String, email As String
    Dim attachmentsList As String
    Dim lastRow As Long
    
    ' 指定数据所在工作表
    Set ws = ThisWorkbook.Sheets("Base")
    ' 用字典按ID分组存储邮箱和附件
    Set dict = CreateObject("Scripting.Dictionary")
    ' 获取A列最后一行数据
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历所有数据行，收集每个ID对应的邮箱和附件
    For Each cell In ws.Range("A2:A" & lastRow)
        id = cell.Value
        email = cell.Offset(0, 1).Value ' 取B列邮箱
        attachD = cell.Offset(0, 3).Value ' 取D列附件路径
        attachE = cell.Offset(0, 4).Value ' 取E列附件路径
        
        ' 首次遇到该ID时，初始化存储结构
        If Not dict.Exists(id) Then
            dict(id) = Array(email, "")
        End If
        
        ' 把D列非空附件加入列表
        If attachD <> "" Then
            dict(id)(1) = dict(id)(1) & attachD & ";"
        End If
        ' 把E列非空附件加入列表
        If attachE <> "" Then
            dict(id)(1) = dict(id)(1) & attachE & ";"
        End If
    Next cell
    
    ' 启动Outlook应用
    Set outlookApp = CreateObject("Outlook.Application")
    
    ' 遍历每个ID，生成对应邮件
    For Each id In dict.Keys
        Set mailItem = outlookApp.CreateItem(0)
        email = dict(id)(0)
        ' 去掉附件列表末尾多余的分号
        attachmentsList = Left(dict(id)(1), Len(dict(id)(1)) - 1)
        
        With mailItem
            .To = email
            .Subject = "ID:" & id & " 对应的附件" ' 可自定义邮件主题
            .Body = "这是ID " & id & " 的所有附件：" & vbCrLf & Replace(attachmentsList, ";", vbCrLf)
            ' 逐个添加附件，先检查文件是否存在
            For Each attachPath In Split(attachmentsList, ";")
                If Dir(attachPath) <> "" Then
                    .Attachments.Add attachPath
                End If
            Next attachPath
            .Display ' 显示邮件，要直接发送就改成.Send
        End With
    Next id
    
    ' 释放占用的对象
    Set mailItem = Nothing
    Set outlookApp = Nothing
    Set dict = Nothing
    Set ws = Nothing
    
    MsgBox "邮件生成完成！"
End Sub

代码关键说明 #

• 用字典按A列ID分组，确保每个ID只生成一封邮件，彻底避免重复发送
• 自动收集对应ID下D、E列的所有附件，空单元格会自动跳过
• 添加附件前会检查文件路径是否有效，避免因文件不存在报错
• 邮件正文会列出所有附件路径，清晰明了；主题和正文可根据需求自行修改

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