Worksheet_Change事件代码执行不稳定问题求助

这段代码有时候才会正常工作。第一个Change事件总会触发，但第二个事件不会。当我清空工作表并添加新的班次数据时，公式插入并不总是生效。With Target之后的部分更是随机失效。有没有大佬能帮忙看看为什么它不能稳定运行？

以下是我提供的代码：

Private Sub Worksheet_Change(ByVal Target As Range)

Dim DestWH As String

Dim DWHRowNum As Long

Dim toDay As String, nextDay As String

DWHRowNum = 2

toDay = Format(Date, "mm/dd/yyyy")

nextDay = Format(Date + 1, "mm/dd/yyyy")

Application.EnableEvents = False

Do Until Cells(DWHRowNum, 2).Value = ""

Select Case Cells(DWHRowNum, 6).Value

Case "ABQ1", "CLE2", "DEN3", "GEG1", "LIT1", "ORD5", "ORF3", "PAE2", "PCW1", "SLC1"

Cells(DWHRowNum, 7).Value = toDay

Cells(DWHRowNum, 8).Value = "17:00"

Case "BFI4", "DEN4", "PDX9", "SMF1"

Cells(DWHRowNum, 7).Value = nextDay

Cells(DWHRowNum, 8).Value = "04:30"

End Select

DWHRowNum = DWHRowNum + 1

Loop

' ** Update

With Target

If .CountLarge = 1 Then

If Not Application.Intersect(Target, Me.Range("N2:N28")) Is Nothing Then

Dim vValue

vValue = .Value

If Len(vValue) > 0 And IsDate(vValue) Then

If Not Me.Range("Q2").HasFormula Then

Me.Range("Q2:Q28").Formula = "=IF(G2="""","""",IF(AND(M2="""",N2>G2),""Future"",""Current""))"

End If

End If

End If

End If

End With

Application.EnableEvents = True

End Sub

我来帮你排查几个大概率导致代码不稳定的关键点，都是VBA写Worksheet事件时容易踩的坑：

1. 事件开关没做错误兜底，容易彻底失效 #

你开头就把Application.EnableEvents关了，但如果中间代码执行出错（比如循环时遇到奇怪的单元格值、Range引用出问题），后面的Application.EnableEvents = True根本跑不到，直接导致后续所有Change事件都触发不了，看起来就像代码"随机失效"。

修复方案：加个错误处理块，确保无论代码是否报错，最后都能把事件开关打开：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim DestWH As String
    Dim DWHRowNum As Long
    Dim toDay As String, nextDay As String
    
    DWHRowNum = 2
    toDay = Format(Date, "mm/dd/yyyy")
    nextDay = Format(Date + 1, "mm/dd/yyyy")
    
    Application.EnableEvents = False
    ' 开启错误捕获，跳转到Cleanup标签
    On Error GoTo Cleanup

    ' 原循环逻辑，所有单元格引用加上Me.明确指向当前工作表
    Do Until Me.Cells(DWHRowNum, 2).Value = ""
        Select Case Me.Cells(DWHRowNum, 6).Value
            Case "ABQ1", "CLE2", "DEN3", "GEG1", "LIT1", "ORD5", "ORF3", "PAE2", "PCW1", "SLC1"
                Me.Cells(DWHRowNum, 7).Value = toDay
                Me.Cells(DWHRowNum, 8).Value = "17:00"
            Case "BFI4", "DEN4", "PDX9", "SMF1"
                Me.Cells(DWHRowNum, 7).Value = nextDay
                Me.Cells(DWHRowNum, 8).Value = "04:30"
        End Select
        DWHRowNum = DWHRowNum + 1
        ' 加个安全上限，防止B列一直非空导致无限循环
        If DWHRowNum > 1000 Then Exit Do
    Loop

    ' ** Update部分优化
    Dim intersectRange As Range
    Set intersectRange = Application.Intersect(Target, Me.Range("N2:N28"))
    
    With Target
        If .CountLarge = 1 And Not intersectRange Is Nothing Then
            Dim vValue
            vValue = .Value
            If Len(vValue) > 0 And IsDate(vValue) Then
                ' 去掉原有的HasFormula判断，只要N列有有效日期就确保公式存在
                Me.Range("Q2:Q28").Formula = "=IF(G2="""","""",IF(AND(M2="""",N2>G2),""Future"",""Current""))"
            End If
        End If
    End With

' 错误兜底，确保事件开关恢复
Cleanup:
    Application.EnableEvents = True
    ' 可选：如果需要知道错误信息，可以加这行
    ' If Err.Number <> 0 Then MsgBox "代码出错：" & Err.Description
End Sub

2. 循环终止条件+单元格引用不严谨 #

• 原代码用Cells(DWHRowNum, 2).Value = ""判断终止，但如果B列中间有空值，后面的数据就不会被处理；而且没加Me.，如果用户切换了工作表，会引用到其他表的单元格，直接出错。
• 加个DWHRowNum > 1000的安全判断，避免极端情况下无限循环卡死Excel。

3. Target部分的逻辑限制过严 #

原代码里If Not Me.Range("Q2").HasFormula Then的判断，意味着只要Q2曾经有过公式，后续即使N列更新也不会重新设置公式——但如果用户手动删除了Q列的公式，或者你需要更新公式逻辑，这部分就完全失效了。如果你的需求是只要N列输入有效日期，就确保Q列有正确的公式，直接去掉这个判断即可。

另外把Intersect的结果提前存起来，避免重复计算，代码更高效也更稳定。

备注：内容来源于stack exchange，提问作者Iron Man