Excel VBA Worksheet_Change事件多单元格粘贴时Offset(0,-2)失效求助

问题原因 #

1. 多单元格区域的Offset取值错误：当Target是多单元格区域时，Target.Offset(0,-2).Value仅返回区域左上角单元格的对应值，无法匹配每个变更单元格的Role（左侧两列）。
2. 表头列数不匹配：初始化表头时Resize(1,6)与数组的7个元素不匹配，导致"Sheet Name"列表头无法正确写入。

修改后的代码 #

Dim RangeValues As Variant, E As Long, boolOne As Boolean, TgValue '存储变更前的目标值数组
Dim sh As Worksheet: Set sh = Worksheets("Change Log")
Dim UN As String: UN = Application.UserName

'sh.Unprotect "" '建议保护日志工作表
If sh.Range("A1") = "" Then 
    '修正：Resize(1,7)匹配7个表头元素
    sh.Range("A1").Resize(1, 7) = _
        Array("Time", "User Name", "Changed cell", "Role", "From", "To", "Sheet Name")
End If

Application.ScreenUpdating = False '优化代码运行速度
Application.Calculation = xlCalculationManual
If Intersect(Target, Range("WENAMES")) Is Nothing Then Exit Sub

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后触发变更事件
    Application.Undo
    RangeValues = extractData(Target) '获取变更前的值
    putDataBack TgValue, ActiveSheet '恢复变更后的数据
    If boolOne Then Target.Offset(1).Select
Application.EnableEvents = True

For E = 0 To UBound(RangeValues)
    If RangeValues(E)(0) <> TgValue(E)(0) Then
        '修正：通过单元格地址定位到具体单元格，再取其左侧两列的Role值
        Dim changedCell As Range
        Set changedCell = Range(RangeValues(E)(1))
        sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 7).Value = _
            Array(Now, UN, changedCell.Address(0, 0), changedCell.Offset(0, -2).Value, _
                  RangeValues(E)(0), TgValue(E)(0), changedCell.Parent.Name)
    End If
Next E

'sh.Protect ""
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

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

关键修改说明 #

• 表头列数修正：将Resize(1,6)改为Resize(1,7)，确保7个表头字段全部写入。
• Role字段取值修正：通过Range(RangeValues(E)(1))定位到每个变更的具体单元格，再调用Offset(0,-2).Value获取对应Role值，保证多单元格粘贴时每个条目都能匹配正确的Role。

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