单工作表单独发邮件VBA宏IF语句故障求助

问题描述 #

我编写了一个VBA宏，用于将每个工作表单独发送为独立邮件，但代码中标记的IF语句（原代码中#所在行）在L9单元格有数据时出现卡顿，导致宏无法继续运行，请求排查原因。

原代码 #

Sub Mail_Every_Worksheet()
'Working in Excel 2000-2013
    Dim sh As Worksheet
    Dim wb As Workbook
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object

    TempFilePath = Environ$("temp") & "\"

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2013
        FileExtStr = ".xlsm": FileFormatNum = 52
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set OutApp = CreateObject("Outlook.Application")

    For Each sh In ThisWorkbook.Worksheets
# If sh.Range("L9").Value Like " " Then***

            sh.Copy
            Set wb = ActiveWorkbook

            TempFileName = ThisWorkbook.Name & " " & sh.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

            Set OutMail = OutApp.CreateItem(0)

            With wb
                .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

                On Error Resume Next
                With OutMail
                    .to = sh.Range("L9").Value
                    .CC = ""
                    .BCC = ""
                    .Subject = ThisWorkbook.Name
                    .Body = "Please see attached updated P&L Report. Thanks"
                                       
                    .Attachments.Add wb.FullName
                    'You can add other files also like this
                    '.Attachments.Add ("C:\test.txt")
                    .Send   'or use .Display
                End With
                On Error GoTo 0

                .Close savechanges:=False
            End With
            
            Set OutMail = Nothing

            Kill TempFilePath & TempFileName & FileExtStr

        End If
    Next sh

    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

卡顿原因分析 #

1. IF条件逻辑完全错误：原代码If sh.Range("L9").Value Like " " Then是判断L9是否等于单个空格，但实际需求应该是L9有有效邮箱时才执行发邮件。当L9是正常邮箱地址时，条件不成立会直接跳过；如果L9是包含空格的无效内容，进入分支后会因邮箱格式错误导致卡顿，且错误被掩盖。
2. 错误处理掩盖问题：On Error Resume Next会忽略发送邮件时的所有错误（比如邮箱格式无效、Outlook权限不足），导致卡顿但看不到具体错误提示，无法定位问题。
3. 语法错误：原IF语句结尾的***是无效字符，会触发语法解析错误，导致宏执行中断。
4. 对象释放不彻底：如果发送邮件出错，可能无法执行到Set OutMail = Nothing和Set wb = Nothing，导致Outlook和Excel对象残留，引发卡顿。

解决方案 #

1. 修正IF条件逻辑

将判断条件改为L9不为空且是有效邮箱地址，避免无效分支执行：

If Trim(sh.Range("L9").Value) <> "" And IsValidEmail(sh.Range("L9").Value) Then

同时添加邮箱验证函数，确保地址格式合法：

Function IsValidEmail(email As String) As Boolean
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,}$"
    regex.IgnoreCase = True
    IsValidEmail = regex.Test(email)
End Function

2. 替换错误处理方式

移除On Error Resume Next，改用针对性的错误捕获，出现问题时弹出提示并清理资源：

On Error GoTo MailError
' 发送邮件代码
On Error GoTo 0

' 错误处理分支
MailError:
    MsgBox "发送邮件到 " & sh.Range("L9").Value & " 失败：" & Err.Description
    ' 强制清理资源
    If Not wb Is Nothing Then
        wb.Close savechanges:=False
        Set wb = Nothing
    End If
    If Not OutMail Is Nothing Then Set OutMail = Nothing
    Kill TempFilePath & TempFileName & FileExtStr
    Resume Next

3. 修复语法错误

删除IF语句后的***无效字符，确保代码语法正确。

4. 确保资源彻底释放

在关闭临时工作簿后，立即释放wb对象：Set wb = Nothing，避免对象残留。

完整修正代码 #

Sub Mail_Every_Worksheet()
'Working in Excel 2000-2013
    Dim sh As Worksheet
    Dim wb As Workbook
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object

    TempFilePath = Environ$("temp") & "\"

    If Val(Application.Version) < 12 Then
        'Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'Excel 2007及以后版本
        FileExtStr = ".xlsm": FileFormatNum = 52
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set OutApp = CreateObject("Outlook.Application")

    For Each sh In ThisWorkbook.Worksheets
        '判断L9是否为有效邮箱
        If Trim(sh.Range("L9").Value) <> "" And IsValidEmail(sh.Range("L9").Value) Then
            sh.Copy
            Set wb = ActiveWorkbook

            TempFileName = ThisWorkbook.Name & " " & sh.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

            Set OutMail = OutApp.CreateItem(0)

            With wb
                .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

                On Error GoTo MailError
                With OutMail
                    .To = sh.Range("L9").Value
                    .CC = ""
                    .BCC = ""
                    .Subject = ThisWorkbook.Name
                    .Body = "Please see attached updated P&L Report. Thanks"
                                       
                    .Attachments.Add wb.FullName
                    '.Attachments.Add ("C:\test.txt")
                    .Send '测试阶段可改用.Display
                End With
                On Error GoTo 0

                .Close savechanges:=False
            End With
            
            Set OutMail = Nothing
            Set wb = Nothing

            Kill TempFilePath & TempFileName & FileExtStr
        End If
    Next sh

    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    Exit Sub

'错误处理分支
MailError:
    MsgBox "发送邮件到 " & sh.Range("L9").Value & " 失败：" & Err.Description
    '清理资源
    If Not wb Is Nothing Then
        wb.Close savechanges:=False
        Set wb = Nothing
    End If
    If Not OutMail Is Nothing Then Set OutMail = Nothing
    On Error Resume Next
    Kill TempFilePath & TempFileName & FileExtStr
    On Error GoTo 0
    Resume Next
End Sub

'邮箱格式验证函数
Function IsValidEmail(email As String) As Boolean
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,}$"
    regex.IgnoreCase = True
    IsValidEmail = regex.Test(email)
End Function

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