Excel VBA批量生成带附件邮件时单个附件缺失无法正常生成问题求助

问题根因 #

• 原有代码仅依赖On Error Resume Next忽略附件添加错误，Office版本升级后，附件添加触发的错误状态未及时清空，会导致后续所有合法附件都无法正常添加
• 未提前校验附件文件是否存在，也未跳过空白的附件名单元格，边缘场景下逻辑异常
• 原有日期计算逻辑存在类型错误：DateAdd函数作用于格式化后的字符串而非日期类型，部分场景下会出现日期计算偏差

修改后完整代码 #

Option Explicit
Sub SendEmailsWeeklys()
    Dim olApp As Object
    Dim olMailItm As Object
    Dim cell As Range, D As Range
    Dim Subj As String
    Dim EmailAddr As String
    Dim Msg As String
    Dim WkEnd As String
    Dim RS As Integer
    Dim filePath As String
    
    If ActiveSheet.Name <> "Weekly Distribution" Then Exit Sub
    
    ' 修正日期计算逻辑：先算日期再格式化
    WkEnd = Format(DateAdd("d", -2, Date), "mm/dd/yyyy")
    Set olApp = CreateObject("Outlook.Application")
    
    ' 遍历所有收件人行
    For Each cell In Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
        EmailAddr = cell.Value
        Msg = "Hello," & vbNewLine & vbNewLine & _
        "Attached is the QA Report for the week ending " & WkEnd & "." & vbNewLine & _
        "If you have questions regarding the content of this report, please contact " & _
        cell.Offset(0, 1).Value & "." & vbNewLine & vbNewLine & _
        "Thanks," & vbNewLine & vbNewLine
        
        Subj = "QA Report: " & cell.Offset(0, -1).Value & " - Week Ending " & WkEnd
        
        Set olMailItm = olApp.CreateItem(0)
        With olMailItm
            .To = EmailAddr
            .Subject = Subj
            .Body = Msg
            .Recipients.ResolveAll
            
            ' 遍历当前行所有附件列
            For Each D In Range(cell.Offset(0, 2), cell.Offset(0, 9999).End(xlToLeft))
                ' 跳过空白单元格
                If Trim(D.Value) <> "" Then
                    filePath = "C:\Users\" & Environ$("Username") & "\Desktop\Process Production\" & Trim(D.Value) & ".xlsx"
                    ' 仅添加存在的文件
                    If Dir(filePath) <> "" Then
                        .Attachments.Add filePath
                    End If
                End If
            Next D
            
            If .Attachments.Count = 0 Then
                MsgBox cell.Offset(0, -1).Value & " - No Attachments Present"
            Else
                .Display
                RS = MsgBox("Send?", vbYesNo, "Continue")
                If RS = vbYes Then
                    .Send
                Else
                    Debug.Print cell.Offset(0, -1).Value
                End If
            End If
        End With
    Next
    ' 释放对象
    Set olMailItm = Nothing
    Set olApp = Nothing
End Sub

核心修改点 #

• 新增文件存在性校验：使用Dir函数提前判断附件是否存在，避免触发添加错误
• 增加空白单元格过滤：跳过附件列的空白单元格，避免无效路径拼接
• 修复日期计算逻辑：先调用DateAdd计算日期，再做格式化，避免类型不匹配导致的日期错误
• 优化代码写法：简化单元格引用写法，增加对象释放逻辑，避免内存残留

验证建议 #

测试阶段可先注释掉.Send语句，仅保留.Display预览邮件，确认附件添加逻辑符合预期后再开启自动发送功能。

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