Excel VBA为不同目标值添加多范围触发邮件时第二范围失效求助

核心故障原因 #

你代码的逻辑顺序错误导致L列的判断代码永远不会被执行：

• 编辑L列单元格时，Set xRg = Intersect(Range("K3050:K4000"), Target) 会返回Nothing，接下来的代码 If xRg Is Nothing Then Exit Sub 会直接终止整个Worksheet_Change过程，L列相关的判断逻辑完全不会运行。

其他可优化的逻辑问题 #

1. 逻辑运算优先级错误：VBA中And优先级高于Or，你原本的范围判断没有加括号，会导致判断逻辑不符合预期，比如非数字值也可能触发判断、条件运算顺序错误。
2. L列的范围判断冗余：Target.Value > 0.003 Or Target.Value < 0.003 等价于Target.Value <> 0.003，可简化写法。
3. On Error Resume Next会屏蔽所有报错，排查问题时建议先注释该行，方便定位错误。

修正后的完整代码 #

Dim xRg As Range, rng As Range

'Update by Extendoffice 2018/3/7
Private Sub Worksheet_Change(ByVal Target As Range)
    ' 排查问题时可注释下一行查看报错信息
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
    
    ' K列判断逻辑
    Set xRg = Intersect(Range("K3050:K4000"), Target)
    If Not xRg Is Nothing Then
        If IsNumeric(Target.Value) And (Target.Value > 0.534 Or Target.Value < 0.519) Then
            Call Mail_small_Text_Outlook
        End If
    End If
    
    ' L列判断逻辑，不会被K列的判断阻断
    Set rng = Intersect(Range("L3050:L4000"), Target)
    If Not rng Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value <> 0.003 Then
            Call Mail_small_Text_Outlook
        End If
    End If
End Sub
Sub Mail_small_Text_Outlook()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "There is an out of spec value on 302-0092. Please confirm."
    ' 排查问题时可注释下一行查看报错信息
    On Error Resume Next
    With xOutMail
        .To = "EMAIL HERE"
        .CC = ""
        .BCC = ""
        .Subject = "Out of spec value on 302-0092"
        .Body = xMailBody
        .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

排查验证步骤 #

• 先编辑L列3050-4000范围内的单元格，输入不等于0.003的数值，验证是否触发邮件发送
• 如果仍未触发，可注释掉两处On Error Resume Next，运行时查看报错信息，排查是否是Outlook调用权限、邮件配置等问题

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