Excel VBA事件冲突：Filtermode=False时用填充柄改单元格触发Undo报错

报错根因 #

• 填充柄操作完成后会依次触发SelectionChange（选区变更）、Worksheet_Change（内容变更）两个事件
• SelectionChange事件中修改A列填充色的操作会清空Excel撤销栈：当FilterMode=False时如果A列填充色发生实质变更，撤销栈中存储的用户填充柄操作记录会被清除，后续Worksheet_Change中调用Application.Undo时无操作可撤销，直接触发报错
• FilterMode=True时如果A列颜色已经是目标浅蓝色，不会触发实质格式修改，也就不会清空撤销栈，因此不会报错

优化方案 #

1. 优化SelectionChange事件逻辑 #

仅当A列填充色确实需要调整时才执行赋值操作，避免无意义的格式修改清空撤销栈，同时临时关闭事件、屏幕更新减少额外干扰。

2. 给Undo操作添加错误捕获 #

当撤销栈为空时直接终止日志记录逻辑，避免运行时错误抛出。

修改后完整代码 #

Option Compare Text

Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
    '代码1：当工作表开启筛选时修改A列填充色
    Dim Column_A As Range
    Dim targetColor As Long
    
    ' 临时关闭事件和屏幕更新，避免额外触发事件
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Set Column_A = Me.Range("A3", Me.Range("A" & Me.Rows.Count).End(xlUp))
    ' 根据筛选状态设置目标颜色
    targetColor = IIf(Me.FilterMode = True, RGB(196, 240, 255), RGB(255, 255, 255))
    
    ' 仅当当前颜色与目标色不一致时才修改，避免无意义操作清空撤销栈
    If Column_A.Interior.Color <> targetColor Then
        Column_A.Interior.Color = targetColor
    End If
    
    ' 恢复设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

' 代码2：记录当前工作表变更，写入Log表
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue
    Dim sh As Worksheet: Set sh = Sheets("Log")
    Dim UN As String: UN = Environ$("username")
    
    ' 修改AK列及之后的单元格不记录日志
    If Not Intersect(Target, Range("AK:XFD")) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    If Target.Cells.Count > 1 Then
        TgValue = extractData(Target)
    Else
        TgValue = Array(Array(Target.Value, Target.Address(0, 0)))  ' 把选区内容存入数组，单单元格也统一格式
        boolOne = True
    End If
    
    Application.EnableEvents = False               ' 避免Undo后再次触发Change事件
    On Error Resume Next
    Application.Undo
    ' 撤销失败直接退出，避免后续逻辑出错
    If Err.Number <> 0 Then
        Application.EnableEvents = True
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        Exit Sub
    End If
    On Error GoTo 0 ' 恢复默认错误处理
    
    RangeValues = extractData(Target)          ' 读取修改前的原始值
    putDataBack TgValue, ActiveSheet           ' 恢复用户修改的内容
    If boolOne Then Target.Offset(1).Select
    Application.EnableEvents = True
    
    Dim columnHeader As String, rowHeader As String
    
    For r = 0 To UBound(RangeValues)
        If RangeValues(r)(0) <> TgValue(r)(0) Then
            columnHeader = Cells(1, Range(RangeValues(r)(1)).Column).Value
            rowHeader = Range("B" & Range(RangeValues(r)(1)).Row).Value
            
            Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 6).Value = _
                Array(UN, Now, rowHeader, columnHeader, TgValue(r)(0), RangeValues(r)(0))
               ' 数组项对应：用户名、修改时间、工单号、列名、新值、旧值
            
            Range(RangeValues(r)(1)).EntireRow.AutoFit
            If Range(RangeValues(r)(1)).RowHeight < 53 Then
               Range(RangeValues(r)(1)).RowHeight = 53
            End If
        End If
    Next r
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub putDataBack(arr, sh As Worksheet)
    Dim El
    For Each El In arr
        sh.Range(El(1)).Value = El(0)
    Next
End Sub

Function extractData(rng As Range) As Variant
    Dim a As Range, arr, count As Long, i As Long
    ReDim arr(rng.Cells.Count - 1)
    For Each a In rng.Areas ' 生成嵌套数组，存储单元格值和地址
        For i = 1 To a.Cells.Count
            arr(count) = Array(a.Cells(i).Value, a.Cells(i).Address(0, 0)): count = count + 1
        Next
    Next
    extractData = arr
End Function

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