Excel工作表Change事件VBA代码调试与优化求助

问题根源分析 #

原代码出现“Object Required（运行时错误424）”的主要原因包括：

1. 递归事件触发：当CopyOnAssignment修改单元格时，未禁用事件导致Worksheet_Change递归调用，引发意外的Target范围处理问题。
2. 范围计数溢出：使用Target.Count处理大范围时可能触发整数溢出，而Target.CountLarge更适合处理任意大小的范围。
3. 未处理多单元格变更：原代码仅处理单个单元格的AP列变更，忽略了多单元格同时修改的场景。
4. 不规范的错误抑制：依赖On Error Resume Next处理验证检查，导致潜在的未捕获错误。

修复后的完整代码 #

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim oldValue As String
    Dim newValue As String
    Dim DelimiterType As String
    Dim i As Integer
    Dim arr() As String
    Dim isAPChange As Boolean
    Dim cell As Range
    
    DelimiterType = ", "
    isAPChange = False
    
    ' 禁用事件防止递归触发
    Application.EnableEvents = False
    On Error GoTo Cleanup ' 确保始终恢复事件状态
    
    ' 处理AP列（第42列）变更为"On Assignment"的情况
    For Each cell In Target
        If Not IsError(cell.Value) Then
            If cell.Column = 42 And cell.Value = "On Assignment" Then
                CopyOnAssignment cell.Row
                isAPChange = True ' 标记已处理AP列变更
            End If
        End If
    Next cell
    
    ' 若已处理AP列变更或非单个单元格变更，跳过L列逻辑
    If isAPChange Or Target.CountLarge <> 1 Then
        GoTo Cleanup
    End If
    
    ' 检查是否为L列（第12列）单元格
    If Target.Column <> 12 Then
        GoTo Cleanup
    End If
    
    ' 检查单元格是否包含列表类型的数据验证
    If Not HasValidation(Target) Then
        GoTo Cleanup
    End If
    
    If Target.Validation.Type = xlValidateList Then
        Application.ScreenUpdating = False
        
        newValue = Target.Value
        Application.Undo
        oldValue = Target.Value
        Target.Value = newValue
        
        ' 处理多选值拼接（避免重复）
        If oldValue <> "" Then
            If newValue <> "" Then
                arr = Split(oldValue, DelimiterType)
                ' 检查新值是否已存在于旧值中
                For i = LBound(arr) To UBound(arr)
                    If Trim(arr(i)) = Trim(newValue) Then
                        newValue = ""
                        Exit For
                    End If
                Next i
                ' 若新值不重复则拼接
                If newValue <> "" Then
                    Target.Value = oldValue & DelimiterType & newValue
                End If
            End If
        End If
        
        Application.ScreenUpdating = True
    End If

Cleanup:
    ' 恢复事件和屏幕更新状态
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

' 辅助函数：检查单元格是否存在数据验证
Private Function HasValidation(rng As Range) As Boolean
    Dim valObj As Validation
    On Error Resume Next
    Set valObj = rng.Validation
    HasValidation = Not valObj Is Nothing
    On Error GoTo 0
End Function

Private Sub CopyOnAssignment(rowNum As Integer)
    ' 在此插入你的CopyOnAssignment逻辑
    ' 示例：复制指定行到工作表末尾
    ' Dim targetRow As Long
    ' targetRow = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row + 1
    ' Me.Rows(rowNum).Copy Me.Rows(targetRow)
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' 保留原空实现
End Sub

关键优化点说明 #

1. 递归事件防护：在代码开头禁用事件，并通过错误处理确保无论是否出错都能恢复事件状态，避免递归触发导致的异常。
2. 多单元格处理：遍历Target中的每个单元格，确保AP列的变更处理覆盖多单元格修改场景。
3. 安全范围计数：使用Target.CountLarge替代Target.Count，避免大范围内的整数溢出问题。
4. 稳健的验证检查：通过辅助函数HasValidation规范验证存在性检查，减少对错误抑制的依赖。
5. 完整的多选逻辑：实现了重复值检查和值拼接功能，确保下拉多选时不会添加重复内容。
6. 错误值防护：添加IsError(cell.Value)检查，避免单元格包含错误值时触发异常。

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