如何修改VBA代码实现仅追踪目标工作表特定单元格的变更

我们可以通过添加特定追踪范围的校验逻辑，实现仅记录目标单元格的变更日志。核心思路是先定义需要追踪的单元格范围，再判断变更区域是否属于该范围，若不属于则直接终止程序，不执行后续日志操作。

修改后的完整代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    '===== 关键修改：定义需要追踪的特定单元格范围 =====
    Dim TrackRange As Range
    ' 替换为你实际需要追踪的单元格，支持多区域（用逗号分隔），比如Range("A1:C10, E5:E20")
    Set TrackRange = Me.Range("A1:C10, E5:E20")
    
    ' 若变更区域不在追踪范围内，直接退出程序
    If Intersect(Target, TrackRange) Is Nothing Then Exit Sub
    
    Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue
    Dim sh As Worksheet: Set sh = Worksheets("Log  - Inputs - Divisions")
    Dim UN As String: UN = Application.UserName
 
    'sh.Unprotect "" '建议保护日志表时启用
    If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 6) = _
                                 Array("Time", "User Name", "Changed cell", "From", "To", "Sheet Name")

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    '===== 关键修改：仅处理追踪范围内的变更单元格 =====
    Dim TargetTracked As Range
    Set TargetTracked = Intersect(Target, TrackRange)
     
    If TargetTracked.Cells.Count > 1 Then
       TgValue = extractData(TargetTracked)
    Else
       TgValue = Array(Array(TargetTracked.Formula, TargetTracked.Address(0, 0)))
       boolOne = True
    End If
    Application.EnableEvents = False
    Application.Undo
    RangeValues = extractData(TargetTracked)
    putDataBack TgValue, ActiveSheet
    If boolOne Then TargetTracked.Offset(1).Select
    Application.EnableEvents = True

    For r = 0 To UBound(RangeValues)
       If RangeValues(r)(0) <> TgValue(r)(0) Then
           sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).Formula = _
               Array(Now, UN, RangeValues(r)(1), RangeValues(r)(0), TgValue(r)(0), Target.Parent.Name)
       End If
    Next r
 
    'sh.Protect "" '建议保护日志表时启用
    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)).Formula = 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).Formula, a.Cells(i).Address(0, 0)): count = count + 1
        Next
    Next
    extractData = arr
End Function

关键修改说明 #

1. 定义追踪范围：代码开头的TrackRange变量用于指定需要监控的单元格区域，可根据实际需求修改（支持多个不连续区域，用逗号分隔）。
2. 前置范围校验：通过Intersect(Target, TrackRange) Is Nothing快速判断变更区域是否在追踪范围内，非目标区域的变更会直接跳过日志记录。
3. 限定处理对象：将原代码中所有操作Target的逻辑，替换为操作TargetTracked（即变更区域与追踪范围的交集），确保仅处理需要监控的单元格。

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