VBA批量生成独立邮件异常：仅生成单封而非四封求助

核心问题 #

你的代码在循环外部仅创建了一个OMail对象，后续循环中只是反复修改同一封邮件的收件人属性，最终只会保留最后一次修改的结果，因此仅生成一封邮件。

修复步骤 #

1. 将邮件对象的创建语句移到循环内部，确保每个收件人对应一封全新的邮件草稿。
2. 修正签名逻辑：捕获签名后，将自定义邮件内容与签名合并，避免覆盖Outlook默认签名。
3. 明确使用单元格值而非对象引用，减少潜在的逻辑错误。

修正后的代码 #

Sub EmailAll()
    Dim OApp As Object, OMail As Object, signature As String
    Set OApp = CreateObject("Outlook.Application")
   
    Dim Rlist As Range
    Set Rlist = Range("P" & Selection.Row & ":S" & Selection.Row)
    Dim R As Range
    ' 提前存储主题内容，避免ActiveCell变化导致的异常
    Dim emailSubject As String
    emailSubject = ActiveCell.Value & " & " & ActiveCell.Offset(0, 1).Value
    
    For Each R In Rlist
        ' 为每个收件人创建新的邮件对象
        Set OMail = OApp.CreateItem(0)
        
        With OMail
            .Display ' 显示邮件以加载默认签名
            signature = .HTMLbody ' 捕获签名的HTML内容
            
            .To = R.Value
            .cc = Sheets("Emails").Range("g2").Value
            .Subject = emailSubject
            ' 合并自定义内容与签名
            .HTMLbody = "email contents" & signature
        End With
        
        Set OMail = Nothing ' 释放当前邮件对象
    Next R
    
    Set OApp = Nothing
End Sub

额外验证建议 #

• 可通过Debug.Print Rlist.Address检查Rlist是否正确指向4个收件地址单元格。
• 若运行时仍有异常，确认Outlook已正常启动，且宏权限设置允许执行此代码。

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