Excel VBA批量删除表格单元格报1004错误及格式设置失效问题

问题概述 #

• 选中多个单元格按删除键时，触发错误：1004 Method 'Undo' of object '_Application' failed
• 格式设置模块仅能在.Cells(r, 11)写入数值2，单元格锁定设置未生效

原代码 #

Private Sub Worksheet_Change(ByVal Target As Range)

    Application.ScreenUpdating = False
        
    Dim wsLog As Worksheet
    Dim oList1, oList2, chgTbl As ListObject
    Dim rng As Range, c As Range, sCol As String
    Dim sRowDate, sRowVend, sRowDesc As String
    Dim oldValue, sTo As String, sFrom As String
    Dim r As Long
    
    On Error GoTo myerror
    Application.EnableEvents = False
   
    Set oList1 = Me.ListObjects(1)
    Set oList2 = Me.ListObjects(2)
    Set rng = Union(oList2.DataBodyRange.Columns("A:C"), _
                    oList2.DataBodyRange.Columns("E:AR"))
   
    Set wsLog = ThisWorkbook.Sheets("Change Log")
    Set chgTbl = wsLog.ListObjects(1)
    
    With chgTbl.Range
        Dim rStart As Long, rEnd As Long
        r = chgTbl.ListRows.Count
        
        rStart = r + 1
        For Each c In Target
            If Intersect(c, rng) Is Nothing Then
                ' do nothing
                
            Else
                ' column header
                If c.Column - oList2.DataBodyRange.Column + 1 <= 3 Then
                    sCol = Intersect(c.EntireColumn, oList2.HeaderRowRange).Value
                    
                Else
                    sCol = Intersect(c.EntireColumn, oList1.DataBodyRange.Rows(1)).Value
                End If
                
                
                sRowDate = Intersect(c.EntireRow, oList2.ListColumns(1).DataBodyRange).Value
                sRowVend = Intersect(c.EntireRow, oList2.ListColumns(2).DataBodyRange).Value
                sRowDesc = Intersect(c.EntireRow, oList2.ListColumns(3).DataBodyRange).Value
               
                Application.Undo
                oldValue = c
                Application.Undo
                
                
                ' so that empty values are easier to read versus just ****
                If c.Value = "" Then
                    sTo = "EMPTY"
                    sFrom = oldValue
                    
                ElseIf oldValue = 0 Then
                   sTo = c.Value
                   sFrom = "EMPTY"
                   
                ElseIf oldValue <> 0 Then
                   sTo = c.Value
                   sFrom = oldValue
                End If
                

                ' prevent recording when deleting empty cell
                If sTo = "EMPTY" And sFrom = "" Then
                    'do nothing
                    
                Else
                    'log it
                    Dim NewRow As ListRow
                    Set NewRow = chgTbl.ListRows.Add
                    r = 1

                    With NewRow.Range
                        .Cells(r, 1) = Environ("username") ' user
                        .Cells(r, 2) = Format(Now(), "DD MMMM") 'date of Change
                        .Cells(r, 3) = Me.Name ' month
                        .Cells(r, 4) = sRowDate ' expense date
                        .Cells(r, 5) = sRowVend ' vendor
                        .Cells(r, 6) = sRowDesc ' description
                        .Cells(r, 7) = sCol ' account (column name)
                        .Cells(r, 8) = sTo ' new value
                        .Cells(r, 9) = sFrom ' old value
                        .Cells(r, 10) = sCol & " was changed to **" & sTo & "** from **" _
                            & sFrom & "** by " & Environ("username") & " on" & " " & _
                            Format(Now(), "DD MMMM YYYY @ H:MM:ss")
                        .Cells(r, 11) = 2
                    End With
                End If
            End If
            
        Next
        rEnd = r
        
        ' change format
        For r = rStart To rEnd
            If .Cells(r, 11) = 2 Then
                .Cells(r, 11).Locked = False
            Else
                
            End If
            .Cells(r, 11).ClearContents
        Next
        
        wsLog.Columns("B:J").AutoFit
    End With
    
myerror:
    Application.EnableEvents = True
    If Err.Number Then MsgBox Err.Number & " " & Err.Description

End Sub

问题修复方案 #

1. 多单元格删除时的Undo错误修复 #

问题原因：批量删除单元格时，连续执行两次Application.Undo会导致撤销栈为空——第一次Undo恢复了删除操作，第二次Undo已无动作可撤销，触发1004错误。

修复逻辑：

• 先记录Target的坐标范围，避免Undo后Target对象失效
• 执行一次Undo获取所有旧值存入数组
• 再执行一次Undo（即Redo）恢复用户的变更操作
• 循环处理每个单元格时，从数组中读取对应旧值

修改核心代码片段：

' 在For Each c In Target前添加以下逻辑
Dim targetAddr As String
Dim oldVals As Variant
targetAddr = Target.Address ' 记录Target地址
Application.Undo
oldVals = Range(targetAddr).Value ' 获取所有旧值
Application.Undo ' 恢复变更

' 循环中替换原来的两次Undo和oldValue赋值
For Each c In Target
    If Intersect(c, rng) Is Nothing Then
        ' do nothing
    Else
        ' ... 省略其他不变代码 ...
        
        ' 获取旧值：根据单元格在Target中的位置从数组读取
        Dim idxRow As Long, idxCol As Long
        idxRow = c.Row - Target.Row + 1
        idxCol = c.Column - Target.Column + 1
        If Target.Cells.Count > 1 Then
            oldValue = oldVals(idxRow, idxCol)
        Else
            oldValue = oldVals
        End If
        
        ' ... 省略其他不变代码 ...

2. 单元格锁定未生效修复 #

问题原因：

• 日志工作表未开启保护，单元格的Locked属性仅在工作表保护时生效
• 代码中rEnd = r的赋值错误：循环添加新行时r被设为1，导致后续格式循环的范围无效
• 先判断单元格值再清除内容，可能因数据未及时刷新导致判断失效

修复逻辑：

• 确保日志工作表处于保护状态（可手动开启或在代码中添加自动保护逻辑）
• 修正rEnd的赋值为chgTbl.ListRows.Count，确保循环覆盖所有新增行
• 调整顺序：先读取单元格值再设置锁定，最后清除内容

修改核心代码片段：

' 自动设置工作表保护（可选，根据需求调整密码）
wsLog.Protect Password:="", UserInterfaceOnly:=True

' 替换原格式设置代码
rEnd = chgTbl.ListRows.Count ' 修正rEnd的值
For r = rStart To rEnd
    Dim lockFlag As Boolean
    lockFlag = (.Cells(r, 11).Value = 2)
    .Cells(r, 11).ClearContents ' 先清除内容
    If lockFlag Then
        .Cells(r, 11).Locked = False
    End If
Next

完整修复后代码 #

Private Sub Worksheet_Change(ByVal Target As Range)

    Application.ScreenUpdating = False
        
    Dim wsLog As Worksheet
    Dim oList1, oList2, chgTbl As ListObject
    Dim rng As Range, c As Range, sCol As String
    Dim sRowDate, sRowVend, sRowDesc As String
    Dim oldValue, sTo As String, sFrom As String
    Dim r As Long
    
    On Error GoTo myerror
    Application.EnableEvents = False
   
    Set oList1 = Me.ListObjects(1)
    Set oList2 = Me.ListObjects(2)
    Set rng = Union(oList2.DataBodyRange.Columns("A:C"), _
                    oList2.DataBodyRange.Columns("E:AR"))
   
    Set wsLog = ThisWorkbook.Sheets("Change Log")
    Set chgTbl = wsLog.ListObjects(1)
    
    ' 自动设置工作表保护（可选，空密码可根据需求修改）
    wsLog.Protect Password:="", UserInterfaceOnly:=True
    
    With chgTbl.Range
        Dim rStart As Long, rEnd As Long
        r = chgTbl.ListRows.Count
        
        rStart = r + 1
        
        ' 修复多单元格Undo问题：先批量获取旧值
        Dim targetAddr As String
        Dim oldVals As Variant
        targetAddr = Target.Address
        Application.Undo
        oldVals = Range(targetAddr).Value
        Application.Undo
        
        For Each c In Target
            If Intersect(c, rng) Is Nothing Then
                ' do nothing
                
            Else
                ' column header
                If c.Column - oList2.DataBodyRange.Column + 1 <= 3 Then
                    sCol = Intersect(c.EntireColumn, oList2.HeaderRowRange).Value
                    
                Else
                    sCol = Intersect(c.EntireColumn, oList1.DataBodyRange.Rows(1)).Value
                End If
                
                
                sRowDate = Intersect(c.EntireRow, oList2.ListColumns(1).DataBodyRange).Value
                sRowVend = Intersect(c.EntireRow, oList2.ListColumns(2).DataBodyRange).Value
                sRowDesc = Intersect(c.EntireRow, oList2.ListColumns(3).DataBodyRange).Value
               
                ' 获取对应单元格的旧值
                Dim idxRow As Long, idxCol As Long
                idxRow = c.Row - Target.Row + 1
                idxCol = c.Column - Target.Column + 1
                If Target.Cells.Count > 1 Then
                    oldValue = oldVals(idxRow, idxCol)
                Else
                    oldValue = oldVals
                End If
                
                ' 空值处理逻辑
                If c.Value = "" Then
                    sTo = "EMPTY"
                    sFrom = oldValue
                    
                ElseIf oldValue = 0 Then
                   sTo = c.Value
                   sFrom = "EMPTY"
                   
                ElseIf oldValue <> 0 Then
                   sTo = c.Value
                   sFrom = oldValue
                End If
                

                ' 跳过空单元格删除的记录
                If sTo = "EMPTY" And sFrom = "" Then
                    'do nothing
                    
                Else
                    ' 写入变更日志
                    Dim NewRow As ListRow
                    Set NewRow = chgTbl.ListRows.Add
                    r = 1

                    With NewRow.Range
                        .Cells(r, 1) = Environ("username") ' 操作人
                        .Cells(r, 2) = Format(Now(), "DD MMMM") ' 变更日期
                        .Cells(r, 3) = Me.Name ' 工作表名称
                        .Cells(r, 4) = sRowDate ' 费用日期
                        .Cells(r, 5) = sRowVend ' 供应商
                        .Cells(r, 6) = sRowDesc ' 描述
                        .Cells(r, 7) = sCol ' 账户列名
                        .Cells(r, 8) = sTo ' 新值
                        .Cells(r, 9) = sFrom ' 旧值
                        .Cells(r, 10) = sCol & " was changed to **" & sTo & "** from **" _
                            & sFrom & "** by " & Environ("username") & " on" & " " & _
                            Format(Now(), "DD MMMM YYYY @ H:MM:ss")
                        .Cells(r, 11) = 2
                    End With
                End If
            End If
            
        Next
        rEnd = chgTbl.ListRows.Count ' 修正rEnd赋值
        
        ' 格式设置逻辑
        For r = rStart To rEnd
            Dim lockFlag As Boolean
            lockFlag = (.Cells(r, 11).Value = 2)
            .Cells(r, 11).ClearContents
            If lockFlag Then
                .Cells(r, 11).Locked = False
            End If
        Next
        
        wsLog.Columns("B:J").AutoFit
    End With
    
myerror:
    Application.EnableEvents = True
    Application.ScreenUpdating = True ' 恢复屏幕更新
    If Err.Number Then MsgBox Err.Number & " " & Err.Description

End Sub

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