嘿，你的问题很典型——原代码只针对第2行的单条记录生成邮件，要实现批量发送，核心就是遍历所有有效数据行，为每一行创建独立的邮件。下面是修改后的完整代码，我会把关键改动点给你讲清楚：

修改后的VBA代码 #

Option Explicit
Sub SendBulkMails()
    Dim objOutlook As Object
    Dim objMail As Object
    Dim lastRow As Long
    Dim i As Long
    
    ' 初始化Outlook应用对象
    Set objOutlook = CreateObject("Outlook.Application")
    
    ' 自动获取数据区域的最后一行（以A列序号为判断依据，空行视为数据结束）
    lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    
    ' 从第2行开始循环遍历所有记录（第1行是表头）
    For i = 2 To lastRow
        ' 为当前行创建新的邮件实例
        Set objMail = objOutlook.CreateItem(0)
        
        With ActiveSheet
            With objMail
                .To = .Range("C" & i).Value ' 读取当前行的收件邮箱
                .CC = .Range("D" & i).Value ' 补充读取抄送邮箱（原表格D列你之前没用到，这里加上）
                .Subject = .Range("E" & i).Value ' 读取邮件主题
                .Body = .Range("G" & i).Value ' 读取邮件内容
                
                ' 处理附件：先判断路径是否为空，避免报错
                If Trim(.Range("F" & i).Value) <> "" Then
                    On Error Resume Next ' 防止文件不存在导致整个批量任务中断
                    .Attachments.Add .Range("F" & i).Value
                    On Error GoTo 0
                End If
                
                .Display ' 如果你想直接发送不用预览，把这行改成 .Send 即可
            End With
        End With
        
        ' 及时释放当前邮件对象，避免内存占用
        Set objMail = Nothing
    Next i
    
    ' 释放Outlook对象
    Set objOutlook = Nothing
    MsgBox "批量邮件创建完成！", vbInformation
End Sub

关键改动说明 #

• 新增循环逻辑：通过lastRow自动识别最后一行数据，用For循环遍历每一条记录，每行生成独立邮件
• 补充抄送功能：原表格D列是抄送邮箱，之前的代码没用到，现在帮你补上了
• 容错处理：添加了附件路径空值判断和错误捕获，就算某行的文件路径无效，也不会中断整个批量任务
• 内存优化：循环内及时释放单个邮件对象，避免长时间运行占用过多内存

使用小提示 #

• 确保Outlook处于打开状态（或者代码会自动启动Outlook，但可能需要你授权访问）
• 如果不需要预览邮件直接发送，把.Display替换成.Send就行
• 待发送文件的路径必须是绝对路径（比如D:\Projects\Report.pdf），相对路径可能会导致找不到文件

内容的提问来源于stack exchange，提问作者Mr.M