Excel VBA删除单元格数据报运行时错误424/1004修复求助

问题根源 #

• 运行时错误424：删除第11列单元格内容时，代码没有做空值判断，访问空单元格的Text、Value属性或依赖对象时找不到对应对象触发报错
• 运行时错误1004：原代码多次重复遍历同一触发范围，且边遍历边删除行，会导致已标记的遍历范围偏移失效，触发范围引用错误
• 用户误改代码问题：原代码没有做错误屏蔽，出错时直接弹出VBA调试入口，非专业用户容易误操作修改代码

修复后的完整VBA代码 #

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngTrigger As Range
    Dim a As Range, rngToDel As Range
    Dim xCellColumn As Integer, xTimeColumn As Integer
    Dim xRow As Long, xCol As Integer
    Dim xDPRg As Range, xRg As Range
    
    ' 初始化配置参数
    xCellColumn = 11
    xTimeColumn = 12
    
    ' 判断是否为第11列的有效修改，不是直接退出
    Set rngTrigger = Intersect(Target, Columns(xCellColumn), Me.UsedRange.Offset(1, 0))
    If rngTrigger Is Nothing Then Exit Sub
    
    ' 开启错误捕获，关闭事件防止循环触发脚本
    On Error GoTo ErrHandler
    Application.EnableEvents = False
    
    ' 单次遍历处理所有逻辑
    For Each a In rngTrigger
        xRow = a.Row
        ' 单元格为空（删除内容）直接跳过处理
        If a.Text <> "" Then
            ' 写入更新时间
            Me.Cells(xRow, xTimeColumn) = Now
            ' 处理依赖单元格更新逻辑，加空判断避免无依赖时报错
            On Error Resume Next
            Set xDPRg = a.Dependents
            On Error GoTo ErrHandler
            If Not xDPRg Is Nothing Then
                For Each xRg In xDPRg
                    If xRg.Column = xCellColumn Then
                        Me.Cells(xRg.Row, xTimeColumn) = Now
                    End If
                Next
            End If
            ' 复制到通用备份表Sheet3
            a.EntireRow.Copy Destination:=Sheet3.Cells(Sheet3.Rows.Count, 1).End(xlUp).Offset(1, 0)
            
            ' 按状态归档到对应工作表，先收集要删除的行
            Select Case a.Value
                Case "Closed Won"
                    a.EntireRow.Copy Destination:=Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0)
                    If rngToDel Is Nothing Then Set rngToDel = a Else Set rngToDel = Union(rngToDel, a)
                Case "Closed Lost"
                    a.EntireRow.Copy Destination:=Sheet5.Cells(Sheet5.Rows.Count, 1).End(xlUp).Offset(1, 0)
                    If rngToDel Is Nothing Then Set rngToDel = a Else Set rngToDel = Union(rngToDel, a)
                Case "Renewal"
                    a.EntireRow.Copy Destination:=Sheet6.Cells(Sheet6.Rows.Count, 1).End(xlUp).Offset(1, 0)
                    If rngToDel Is Nothing Then Set rngToDel = a Else Set rngToDel = Union(rngToDel, a)
            End Select
        End If
    Next a
    
    ' 统一删除所有需要移除的行，避免边遍历边删除导致范围失效
    If Not rngToDel Is Nothing Then
        rngToDel.EntireRow.Delete
    End If

SafeExit:
    Application.EnableEvents = True
    Exit Sub
    
ErrHandler:
    ' 出错仅弹出提示，不开放调试入口
    MsgBox "脚本提醒：" & Err.Description, vbInformation
    Resume SafeExit
End Sub

额外防护设置（防止用户误改代码） #

按Alt+F11进入VBA编辑器，点击顶部菜单「工具」→「VBAProject 属性」，切换到「保护」标签页，勾选「查看时锁定工程」，设置密码后保存文件即可。后续普通用户无法进入代码编辑界面，完全避免误修改问题。

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