Excel VBA多收件人批量发邮件：逐行读日期按需加附件方法

你现有逐行遍历C列邮箱生成邮件的循环逻辑可以直接复用，两个扩展功能不需要重构原有代码，只需要在单封邮件的生成逻辑块里补充对应行的取值、判断操作即可，具体实现方式如下：

核心实现逻辑 #

• 逐行匹配D列日期：遍历数据行时，直接通过当前循环行号定位D列单元格取值即可，和同行走C列取邮箱的逻辑完全一致，不会出现行数据错位。取到日期后建议先做格式化处理，避免Excel日期序列值直接显示为5位数字，替换掉正文里提前留好的占位符就行。
• E列可选附件追加：同样取当前循环行E列的文件路径，先判断单元格非空、且路径对应的文件真实存在，再调用附件添加方法追加到邮件里，不影响原有固定附件的加载；如果E列为空或者路径无效直接跳过即可，不会中断批量发件流程。

可直接复用的代码示例 #

假设你的数据表第1行是表头，有效数据从第2行开始，固定附件路径提前写在常量里，正文预留日期插入位：

Sub SendEmailWithRowData()
    Dim olApp As Object, olMail As Object
    Dim lastRow As Long, i As Long
    Dim fixedAttachPath As String, customAttachPath As String
    Dim mailBody As String, sendDate As String
    
    ' 配置项 - 按需修改
    fixedAttachPath = "C:\固定文件\通用通知.pdf" ' 原有固定附件路径
    Const mailSubject = "请查收对应日期的通知材料" ' 邮件主题
    
    ' 初始化Outlook（后期绑定，不需要手动加库引用）
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        MsgBox "请先启动Outlook再运行宏"
        Exit Sub
    End If
    
    ' 取C列最后一行有有效数据的行号
    lastRow = Cells(Rows.Count, "C").End(xlUp).Row
    
    ' 逐行遍历生成邮件
    For i = 2 To lastRow ' 从第2行开始，跳过表头行
        ' 跳过C列邮箱为空的无效行
        If Trim(Cells(i, "C").Value) <> "" Then
            ' 取当前行D列日期，按需求格式化
            sendDate = Format(Cells(i, "D").Value, "yyyy年mm月dd日")
            ' 组装邮件正文，插入对应日期
            mailBody = "您好：" & vbCrLf & vbCrLf & _
                       "请查收" & sendDate & "对应的相关材料，详见附件。" & vbCrLf & vbCrLf & _
                       "此致"
            ' 创建新邮件
            Set olMail = olApp.CreateItem(0)
            With olMail
                .To = Cells(i, "C").Value ' 读取当前行C列收件人地址
                .Subject = mailSubject
                .Body = mailBody
                ' 加载原有固定附件
                If Dir(fixedAttachPath) <> "" Then .Attachments.Add fixedAttachPath
                ' 判断当前行E列是否有附件路径，校验存在后追加
                customAttachPath = Trim(Cells(i, "E").Value)
                If customAttachPath <> "" Then
                    If Dir(customAttachPath) <> "" Then
                        .Attachments.Add customAttachPath
                    End If
                End If
                ' 调试阶段用.Display弹出邮件预览，确认无误后可替换为.Send自动发送
                .Display
            End With
            Set olMail = Nothing
        End If
    Next i
    
    Set olApp = Nothing
    MsgBox "邮件生成完成"
End Sub

注意事项 #

• E列存储的必须是本地文件绝对路径或者局域网共享UNC路径（比如\\公司共享盘\材料\合同001.docx），网页链接无法直接作为附件添加，需要先下载到本地再填写路径
• 调试阶段建议先用.Display方法弹出邮件预览，确认收件人、日期、附件都匹配正确后再改成.Send自动发送，避免发错内容
• 如果需要发送HTML格式的富文本正文，把.Body属性替换为.HTMLBody即可，日期替换、附件添加的逻辑完全不变

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