问题背景 #

原VBA代码用于记录Excel表格的单元格变更操作，单个单元格删除时运行正常，但选中多个单元格执行删除操作时，会触发错误1004：“Method 'Undo' of object '_Application' failed”。经排查，问题出在日志格式设置的条件语句，但该语句需要保留——它的作用是为oList2的日期列（第一列）设置日期格式，其他列设置货币格式。

原代码 #

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim wsLog As Worksheet, oList1 As ListObject, oList2 As ListObject
    Dim rng As Range, c As Range, sCol 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")
    With wsLog
        r = .Cells(.Rows.Count, 2).End(xlUp).Row
        
        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
               
               
                Application.Undo
                oldValue = c
                Application.Undo
                
                
                ' so that empty values are easier to read versus **** in .Cells(r, 8)
                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 logging changes when deleting empty cell
                If sTo = "EMPTY" And sFrom = "" Then
                    'do nothing
                    
                Else
                    'log it
                    r = r + 1
                    .Cells(r, 2) = Me.Name
                    .Cells(r, 3) = sCol ' column name
                    .Cells(r, 4) = Environ("username")
                    .Cells(r, 5) = Format(Now(), "DD MMMM")
                    If c.Column - oList2.DataBodyRange.Column + 1 <= 1 Then
                        .Cells(r, 6) = sTo
                        .Cells(r, 6).NumberFormat = "m/d/yyyy"
                    
                    Else
                        .Cells(r, 6) = sTo
                        .Cells(r, 6).NumberFormat = "$#,##0.00_);($#,##0.00)"
                    End If
                    .Cells(r, 7) = sFrom
                    .Cells(r, 8) = "Was changed to **" & sTo & "** from **" _
                        & sFrom & "** by " & Environ("username") & " on" & " " & _
                        Format(Now(), "DD MMMM, YYYY @ H:MM:ss")
                End If
            End If
            
        Next
        
        .Columns("B:H").AutoFit
    End With
    
myerror:
    Application.EnableEvents = True
    If Err.Number Then MsgBox Err.Number & " " & Err.Description
    
End Sub

问题根源 #

1. 多次Undo冲突：循环中对每个单元格调用Application.Undo，但批量删除是一个单一操作，第一次Undo就会恢复所有被删单元格，后续的Undo会因无操作可撤销而报错。
2. 格式设置时的单元格状态异常：批量删除后，部分单元格已处于空状态，原格式设置语句引用这些单元格时会出现状态不匹配的问题。

解决方案 #

修改代码逻辑，先一次性获取所有目标单元格的旧值，再恢复变更，最后处理日志和格式设置：

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim wsLog As Worksheet, oList1 As ListObject, oList2 As ListObject
    Dim rng As Range, c As Range, sCol As String
    Dim oldValues As Variant, sTo As String, sFrom As String
    Dim r As Long, i As Long
    Dim targetArea As Range
    
    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 rng = Intersect(Target, rng)
    If rng Is Nothing Then GoTo myerror
    
    Set wsLog = ThisWorkbook.Sheets("Change Log")
    r = wsLog.Cells(wsLog.Rows.Count, 2).End(xlUp).Row
    
    ' 一次性获取所有旧值
    Application.Undo
    ReDim oldValues(1 To rng.Cells.Count)
    i = 1
    For Each c In rng
        oldValues(i) = c.Value
        i = i + 1
    Next
    Application.Undo ' 恢复变更
    
    ' 遍历处理每个单元格
    i = 1
    For Each c In rng
        ' 获取列标题
        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
        
        ' 处理新旧值显示逻辑
        If c.Value = "" Then
            sTo = "EMPTY"
            sFrom = oldValues(i)
        ElseIf oldValues(i) = 0 Or oldValues(i) = "" Then
            sTo = c.Value
            sFrom = "EMPTY"
        Else
            sTo = c.Value
            sFrom = oldValues(i)
        End If
        
        ' 跳过空单元格删除的日志
        If Not (sTo = "EMPTY" And sFrom = "") Then
            r = r + 1
            With wsLog
                .Cells(r, 2) = Me.Name
                .Cells(r, 3) = sCol
                .Cells(r, 4) = Environ("username")
                .Cells(r, 5) = Format(Now(), "DD MMMM")
                
                ' 保留格式设置逻辑
                If c.Column - oList2.DataBodyRange.Column + 1 <= 1 Then
                    .Cells(r, 6) = IIf(sTo = "EMPTY", "", sTo)
                    .Cells(r, 6).NumberFormat = "m/d/yyyy"
                Else
                    .Cells(r, 6) = IIf(sTo = "EMPTY", "", sTo)
                    .Cells(r, 6).NumberFormat = "$#,##0.00_);($#,##0.00)"
                End If
                
                .Cells(r, 7) = IIf(sFrom = "EMPTY" Or sFrom = "", "", sFrom)
                .Cells(r, 8) = "Was changed to **" & sTo & "** from **" & sFrom & _
                               "** by " & Environ("username") & " on " & _
                               Format(Now(), "DD MMMM, YYYY @ H:MM:ss")
            End With
        End If
        i = i + 1
    Next
    
    wsLog.Columns("B:H").AutoFit
    
myerror:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
    
End Sub

修改说明 #

• 一次性获取旧值：先执行一次Undo，把所有目标单元格的旧值存入数组，再Undo恢复变更，避免循环中多次调用Undo导致的冲突。
• 优化值处理逻辑：用IIf函数处理空值显示，避免将"EMPTY"写入格式单元格导致格式异常。
• 保留格式设置功能：原有的日期列和货币列格式设置逻辑完整保留，同时适配批量操作场景。

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