如何为Excel多行数据循环生成带附件的VBA邮件？

以下是修改后的代码，可实现逐行读取Excel数据、批量生成带附件的邮件：

Sub Batch_Attachment()
    Dim appOutlook As Object
    Dim Email As Object
    Dim Source, mailto As String
    Dim i As Integer ' 循环变量
    
    ' 创建Outlook应用对象
    Set appOutlook = CreateObject("Outlook.Application")
    
    ' 循环遍历数据行（假设第1行是表头，数据从第2行到第6行，共5行）
    For i = 2 To 6
        ' 每次循环创建新的邮件对象
        Set Email = appOutlook.CreateItem(0) ' 0对应olMailItem常量
        
        ' 获取当前行的收件人邮箱
        mailto = Cells(i, 2).Value
        ' 获取当前行对应的附件路径
        Source = "C:\Users\fk\Desktop\test invoices email\" & Cells(i, 3).Value
        
        ' 添加指定附件（可选错误处理：忽略附件不存在的报错）
        On Error Resume Next
        Email.Attachments.Add Source
        On Error GoTo 0
        
        ' 添加当前工作簿为附件（先保存工作簿）
        ThisWorkbook.Save
        Source = ThisWorkbook.FullName
        Email.Attachments.Add Source
        
        ' 设置邮件基本信息
        Email.To = mailto
        Email.Subject = "Important Sheets"
        Email.Body = "Greetings Everyone," & vbNewLine & "Please go through the Sheets." & vbNewLine & "Regards."
        
        ' 显示邮件（需直接发送可替换为Email.Send）
        Email.Display
    Next i
    
    ' 释放对象，避免内存占用
    Set Email = Nothing
    Set appOutlook = Nothing
End Sub

关键改动说明： #

• 新增循环逻辑：通过For i = 2 To 6遍历5行数据（可根据实际数据行数调整起始/结束行号）
• 独立生成邮件：将创建邮件对象的代码放入循环内，确保每一行数据对应一封独立邮件
• 动态读取行数据：把固定的Cells(2, 2)/Cells(2, 3)替换为Cells(i, 2)/Cells(i, 3)，读取当前循环行的收件人和附件名称
• 容错处理：加入On Error Resume Next避免因附件不存在导致程序中断（可根据需求移除）

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