如何在拖拽复制（AutoFill）事件中获取单元格的原始值？

问题描述 #

我编写了一个记录单元格变更的日志脚本，单个单元格修改时运行正常，但在拖拽复制（AutoFill）操作时遇到问题。日志需要记录变更前和变更后的值，但拖拽复制释放鼠标时新值已经覆盖旧值，不知道如何获取原始值。

举例说明：
A列初始值：

A1=1;
A2=2;
A3=3;
A4=4

将A1的“1”拖拽复制到A4时，日志应显示：

A2: 当前值=1 ; 原始值=2;
A3: 当前值=1 ; 原始值=3;
A4: 当前值=1 ; 原始值=4;

请问如何在AutoFill填充单元格前检测填充区域并获取原始值？

用户原代码：

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

 Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue 'the array to keep Target values (before UnDo)
 Dim sh As Worksheet: Set sh = Sheets("Change Log") 'it returns in a sheet named "Change Log"
                                              
 Dim UN As String: UN = Application.UserName
 
 'If Not Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub      'not doing anything if a cell in A:A is changed
 If Not Intersect(ActiveCell, Range("1:3")) Is Nothing Then Exit Sub  'Not doing anything if a cell is changed in first 3 rows
 'If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 8) = _
 '                                   Array("Date & Time", "User Name", "Changed cell", "From", "To", "Sheet Name", "Column Name")

 Application.ScreenUpdating = False                                     'to optimize the code (make it faster)
 Application.Calculation = xlCalculationManual
 
 If Target.Cells.count > 1 Then
    TgValue = ExtractData(Target)
 Else
    TgValue = Array(Array(Target.Value, Target.Address(0, 0)))  'put the target range in an array (or as a string for a single cell)
    boolOne = True
 End If
 Application.EnableEvents = False                               'avoiding to trigger the change event after Undo
     Application.Undo
     RangeValues = ExtractData(Target)                          'define the RangeValue
     putDataBack TgValue, ActiveSheet                           'put back the changed data
     If boolOne Then Target.Offset(1).Select
 Application.EnableEvents = True

 Dim IdRow As String
 Dim customer As String
 Dim Markup As String
 Dim lsp As String
 Dim columnHeader As String
 For r = 0 To UBound(RangeValues)
    If RangeValues(r)(0) <> TgValue(r)(0) Then
        columnHeader = Cells(4, Range(RangeValues(r)(1)).Column).Value 'headers are on row 4
        lsp = Cells(Range(RangeValues(r)(1)).Row, 5).Value
        customer = Cells(Range(RangeValues(r)(1)).Row, 4).Value
     '   Markup = Cells(Range(RangeValues(r)(1)).Row, 8).Value
        IdRow = Cells(Range(RangeValues(r)(1)).Row, 1).Value
        sh.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 9).Value = _
                Array(Now, IdRow, UN, Range(RangeValues(r)(1)).Row, RangeValues(r)(0), TgValue(r)(0), lsp, _
                                      Target.Parent.Name, columnHeader) ' if you want to see address of the changed cell leavr only RangeValues(r)(1)
    End If
 Next r
 
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

Sub putDataBack(arr, sh As Worksheet)
    Dim i As Long, arrInt, 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 'creating a jagged array containing the values and the cells address
            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

解决方案 #

核心思路是提前缓存AutoFill目标区域的原始值——利用Worksheet_SelectionChange事件在用户选择填充源单元格时，预判可能的填充区域并记录其初始值，避免Worksheet_Change触发时旧值已被覆盖。

修改后的完整代码 #

Option Explicit

' 全局变量：缓存AutoFill前的目标区域值和地址
Private cachedValues As Variant
Private cachedRange As String

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' 仅处理单个单元格选中场景（通常是AutoFill的填充源）
    If Target.Cells.Count = 1 Then
        ' 预判填充目标区域：当前单元格下方连续非空单元格，可根据需求调整范围逻辑
        Dim fillRange As Range
        On Error Resume Next
        Set fillRange = Range(Target.Offset(1), Target.End(xlDown))
        On Error GoTo 0
        
        If Not fillRange Is Nothing Then
            ' 缓存区域地址与对应值
            cachedRange = fillRange.Address
            cachedValues = fillRange.Value
        Else
            ' 无有效填充区域时清空缓存
            cachedRange = ""
            Erase cachedValues
        End If
    Else
        ' 选中多个单元格时清空缓存
        cachedRange = ""
        Erase cachedValues
    End If
End Sub

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("Change Log")
    Dim UN As String: UN = Application.UserName
 
    If Not Intersect(ActiveCell, Range("1:3")) Is Nothing Then Exit Sub

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    ' 分支处理：AutoFill场景 vs 普通修改场景
    If cachedRange <> "" And Not Intersect(Target, Range(cachedRange)) Is Nothing Then
        ' AutoFill场景：直接用缓存的原始值
        TgValue = ExtractData(Target)
        RangeValues = ConvertCachedValues(cachedRange, cachedValues)
    Else
        ' 普通修改场景：保留原有Undo逻辑
        If Target.Cells.Count > 1 Then
            TgValue = ExtractData(Target)
        Else
            TgValue = Array(Array(Target.Value, Target.Address(0, 0)))
            boolOne = True
        End If
        Application.Undo
        RangeValues = ExtractData(Target)
        putDataBack TgValue, ActiveSheet
        If boolOne Then Target.Offset(1).Select
    End If

    ' 写入变更日志
    Dim IdRow As String, customer As String, lsp As String, columnHeader As String
    For r = 0 To UBound(RangeValues)
        If RangeValues(r)(0) <> TgValue(r)(0) Then
            columnHeader = Cells(4, Range(RangeValues(r)(1)).Column).Value
            lsp = Cells(Range(RangeValues(r)(1)).Row, 5).Value
            customer = Cells(Range(RangeValues(r)(1)).Row, 4).Value
            IdRow = Cells(Range(RangeValues(r)(1)).Row, 1).Value
            sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 9).Value = _
                Array(Now, IdRow, UN, Range(RangeValues(r)(1)).Row, RangeValues(r)(0), TgValue(r)(0), lsp, _
                      Target.Parent.Name, columnHeader)
        End If
    Next r

    ' 操作完成后重置缓存
    cachedRange = ""
    Erase cachedValues

    Application.EnableEvents = True
    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

' 将缓存的二维数组转换为与ExtractData一致的锯齿数组格式，保证日志逻辑兼容
Function ConvertCachedValues(rngAddr As String, values As Variant) As Variant
    Dim rng As Range, cell As Range, arr(), count As Long
    Set rng = Range(rngAddr)
    ReDim arr(rng.Cells.Count - 1)
    count = 0
    For Each cell In rng
        arr(count) = Array(values(cell.Row - rng.Row + 1, cell.Column - rng.Column + 1), cell.Address(0, 0))
        count = count + 1
    Next
    ConvertCachedValues = arr
End Function

关键说明 #

1. 全局缓存变量：cachedValues存储目标区域原始值，cachedRange存储区域地址，确保AutoFill触发时能直接调用。
2. 选择事件预判：Worksheet_SelectionChange在用户选中填充源时，自动识别下方连续非空区域作为潜在填充目标，提前缓存数据。
3. 分支逻辑兼容：保留原有普通修改的Undo逻辑，同时针对AutoFill场景跳过Undo，避免数据异常。
4. 格式转换：ConvertCachedValues将缓存的二维数组转换为原有代码兼容的锯齿数组，无需修改日志写入逻辑。

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