Worksheet_Change事件VBA代码导致Excel崩溃求助

我编写了一段在特定单元格更改时运行的VBA代码，希望单元格更改时触发代码执行。但向F2至F28范围内的任意单元格输入数据时，会弹出调试消息，紧接着Excel直接崩溃。代码编译时未显示任何错误，恳请协助解决。

原代码：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim DestWH As String
Dim DWHRowNum As Long
Dim dt As Date

DWHRowNum = 2
dt = Format(Date, "mm/dd/yyy")

Do Until Cells(DWHRowNum, 2).Value = ""
    Select Case Cells(DWHRowNum, 6).Value
        Case Is = "ABQ1"
            Cells(DWHRowNum, 7).Value = dt
            Cells(DWHRowNum, 8).Value = "17:00"
        Case Is = "BFI4"
            Cells(DWHRowNum, 7).Value = dt + 1
            Cells(DWHRowNum, 8).Value = "04:30"
        Case Is = "CLE2"
            Cells(DWHRowNum, 7).Value = dt
            Cells(DWHRowNum, 8).Value = "17:00"
        Case Is = "DEN3"
            Cells(DWHRowNum, 7).Value = dt
            Cells(DWHRowNum, 8).Value = "17:00"
        Case Is = "DEN4"
            Cells(DWHRowNum, 7).Value = dt + 1
            Cells(DWHRowNum, 8).Value = "04:30"
        Case Is = "GEG1"
            Cells(DWHRowNum, 7).Value = dt
            Cells(DWHRowNum, 8).Value = "17:00"
        Case Is = "LIT1"
            Cells(DWHRowNum, 7).Value = dt
            Cells(DWHRowNum, 8).Value = "17:00"
        Case Is = "ORD5"
            Cells(DWHRowNum, 7).Value = dt
            Cells(DWHRowNum, 8).Value = "17:00"
        Case Is = "ORF3"
            Cells(DWHRowNum, 7).Value = dt
            Cells(DWHRowNum, 8).Value = "17:00"
        Case Is = "PAE2"
            Cells(DWHRowNum, 7).Value = dt
            Cells(DWHRowNum, 8).Value = "17:00"
        Case Is = "PCW1"
            Cells(DWHRowNum, 7).Value = dt
            Cells(DWHRowNum, 8).Value = "17:00"
        Case Is = "PDX9"
            Cells(DWHRowNum, 7).Value = dt + 1
            Cells(DWHRowNum, 8).Value = "04:30"
        Case Is = "SLC1"
            Cells(DWHRowNum, 7).Value = dt
            Cells(DWHRowNum, 8).Value = "17:00"
        Case Is = "SMF1"
            Cells(DWHRowNum, 7).Value = dt + 1
            Cells(DWHRowNum, 8).Value = "04:30"
    End Select
    DWHRowNum = DWHRowNum + 1
Loop

End Sub

问题根源 #

1. 事件递归触发：代码修改G、H列单元格时，会再次触发Worksheet_Change事件，形成无限递归，耗尽Excel资源导致崩溃。
2. 循环可能无限运行：如果B列从第2行开始一直有非空值，循环会持续到Excel最大行数，导致程序无响应。
3. 日期类型错误：Format(Date, "mm/dd/yyy")将日期转为字符串，赋值给Date类型变量后，dt + 1的运算会出现类型转换问题。

修复后的代码 #

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 仅处理F2:F28范围内的单元格更改
    If Intersect(Target, Me.Range("F2:F28")) Is Nothing Then Exit Sub
    
    Dim DWHRowNum As Long
    Dim dt As Date
    
    ' 禁用事件，防止修改单元格时递归触发
    Application.EnableEvents = False
    
    DWHRowNum = 2
    dt = Date ' 直接获取日期类型，避免格式转换错误
    
    ' 限制循环范围到F2:F28，避免无限循环
    Do Until DWHRowNum > 28
        Select Case Me.Cells(DWHRowNum, 6).Value
            ' 合并相同处理的仓库代码
            Case "ABQ1", "CLE2", "DEN3", "GEG1", "LIT1", "ORD5", "ORF3", "PAE2", "PCW1", "SLC1"
                Me.Cells(DWHRowNum, 7).Value = dt
                Me.Cells(DWHRowNum, 8).Value = "17:00"
            Case "BFI4", "DEN4", "PDX9", "SMF1"
                Me.Cells(DWHRowNum, 7).Value = dt + 1
                Me.Cells(DWHRowNum, 8).Value = "04:30"
        End Select
        DWHRowNum = DWHRowNum + 1
    Loop
    
    ' 恢复事件触发
    Application.EnableEvents = True
End Sub

关键修改说明 #

• 范围校验：用Intersect判断触发事件的单元格是否在目标范围内，无关操作直接退出，减少无效执行。
• 禁用事件递归：修改单元格前关闭事件触发，操作完成后恢复，彻底解决无限递归导致的崩溃。
• 修正日期变量：直接使用Date函数获取日期类型值，确保后续日期运算正常。
• 限制循环边界：将循环终止条件设为DWHRowNum > 28，对应目标范围F2:F28，避免因B列数据导致的无限循环。
• 简化代码结构：合并相同逻辑的Case分支，让代码更易维护。

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