同一工作表运行两个Worksheet_Change事件触发运行时错误424

出现Run-Time error '424'的核心原因是行删除操作触发了Worksheet_Change事件递归调用：

1. 当你在Worksheet_Change里调用Worksheet_Change1时，删除行的操作会再次触发Worksheet_Change事件，导致Worksheet_Change2被第二次调用
2. 第二次调用时，原Target对应的单元格已经被删除，Target对象失效，访问Target.Cells.Count就会抛出对象缺失错误
3. 另外Worksheet_Change1的循环逻辑存在问题：从前往后循环删除行时，后续行上移会导致部分"Done"行被跳过；Worksheet_Change2里还有冗余的判断代码

关键修复点 #

• 在修改工作表内容的代码块前后禁用/启用事件（Application.EnableEvents），防止递归触发
• 将Worksheet_Change1的循环改为从后往前遍历，避免删除行后跳过数据
• 在Worksheet_Change2开头增加If Target Is Nothing Then Exit Sub判断，处理对象失效的情况
• 清理Worksheet_Change2里冗余的If Target.Cells.Count > 1 Then Exit Sub代码

修改后的完整代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Worksheet_Change1 Target
    Worksheet_Change2 Target
End Sub

Sub Worksheet_Change1(ByVal Target As Range)
    Dim xRg As Range
    Dim A As Long, B As Long, C As Long
    
    ' 禁用事件防止递归触发
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    A = Worksheets("Working").UsedRange.Rows.Count
    B = Worksheets("Completed").UsedRange.Rows.Count
    
    ' 处理Completed表为空的情况
    If B = 1 Then
        If Application.WorksheetFunction.CountA(Worksheets("Completed").UsedRange) = 0 Then B = 0
    End If
    
    Set xRg = Worksheets("Working").Range("I1:I" & A)
    
    ' 从后往前遍历，避免删除行后跳过数据
    For C = xRg.Count To 1 Step -1
        If CStr(xRg(C).Value) = "Done" Then
            xRg(C).EntireRow.Copy Destination:=Worksheets("Completed").Range("A" & B + 1)
            xRg(C).EntireRow.Delete
            B = B + 1
        End If
    Next C
    
    Application.ScreenUpdating = True
    ' 恢复事件
    Application.EnableEvents = True
End Sub

Sub Worksheet_Change2(ByVal Target As Range)
    ' 先判断Target是否有效
    If Target Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
    
    If Not Intersect(Target, Range("G:G")) Is Nothing Then
        Select Case Target.Value
            Case "MOBILARIS"
                Mail_small_Text_Outlook1
            Case "COMMS TECH"
                Mail_small_Text_Outlook2
            Case "PLANNING ENGINEER"
                Mail_small_Text_Outlook3
        End Select
    End If
End Sub

Sub Mail_small_Text_Outlook1()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Hi" & vbNewLine & vbNewLine & _
    "Please check the Comms Issue Register, there has been an issue reported regarding Mobilaris" & vbNewLine & _
    "Thankyou"
    On Error Resume Next
    With xOutMail
        .To = "xxxx"
        .CC = ""
        .BCC = ""
        .Subject = "Mobilaris Issue"
        .Body = xMailBody
        .Send 'or use .Display
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

Sub Mail_small_Text_Outlook2()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Hi" & vbNewLine & vbNewLine & _
    "Please check the Comms Issue Register, there has been an issue reported with comms somewhere UG" & vbNewLine & _
    "Thankyou"
    On Error Resume Next
    With xOutMail
        .To = "xxxx"
        .CC = ""
        .BCC = ""
        .Subject = "Communications Issue"
        .Body = xMailBody
        .Send 'or use .Display
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

Sub Mail_small_Text_Outlook3()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Hi" & vbNewLine & vbNewLine & _
    "Please check the Comms Issue Register, there is Leaky Feeder extensions that are needed to be scheduled" & vbNewLine & _
    "Thankyou"
    On Error Resume Next
    With xOutMail
        .To = "xxxxx"
        .CC = ""
        .BCC = ""
        .Subject = "Leaky Feeder extensions required"
        .Body = xMailBody
        .Send 'or use .Display
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

额外说明 #

1. 事件禁用：在Worksheet_Change1中修改工作表内容时，必须禁用Application.EnableEvents，否则删除行的操作会再次触发Worksheet_Change，导致递归调用，这是引发424错误的核心原因
2. 循环方向：从后往前遍历行，避免删除某一行后，后续行上移导致索引错乱，漏掉需要处理的行
3. 代码优化：将Worksheet_Change2中的多个If判断改为Select Case，代码更简洁易维护
4. 对象有效性判断：在Worksheet_Change2开头先检查Target是否存在，避免对象失效时的错误

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