Question

我正在使用审计跟踪记录在Sheet One上发生的更改并将其记录在Sheet 2上。但代码工作正常，我想限制代码仅在特定单元格上运行，即（A1：L100）。原因是我从M栏开始有一些工作，因此我不想在这些工作中记录任何动作。关于如何添加/修改以下代码的任何建议：

Option Explicit
Public dArr As Variant
Private Sub Worksheet_Calculate()
Dim nArr As Variant
Dim auditRecord As Range
Dim i As Long
Dim j As Long
nArr = Me.UsedRange
 'Look for changes to the used range
For i = 1 To UBound(dArr, 2)
    For j = 1 To UBound(dArr, 1)
        If nArr(j, i) <> dArr(j, i) Then
            'write to range
            If Not Write_Change(dArr(j, i), nArr(j, i), Me.Cells(j, i).Address) Then
                MsgBox "The change was not recorded.", vbInformation
            End If
        End If
    Next j
Next i

Erase nArr, dArr
dArr = Me.UsedRange
End Sub

Private Sub Worksheet_Change(ByVal target As Range)
Dim Cell As Range
Dim oldValue As Variant

For Each Cell In target
    On Error Resume Next
    oldValue = vbNullString
    oldValue = dArr(Cell.Row, Cell.Column)
    On Error GoTo 0
    If oldValue <> Cell.Value Then
        If Not Write_Change(oldValue, Cell.Value, Cell.Address) Then
            MsgBox "The change was not recorded.", vbInformation
        End If
    End If
Next Cell

On Error Resume Next
Erase dArr
On Error GoTo 0

dArr = Me.UsedRange
End Sub

Private Sub Worksheet_SelectionChange(ByVal target As Range)
dArr = Me.UsedRange
End Sub

Public Function Write_Change(oldValue, newValue, cellAddress As String) As     Boolean
Dim auditRecord As Range
On Error GoTo errHandler
Set auditRecord = Sheets("ChangeHistory").Range("A:A").Find("*", searchdirection:=xlPrevious).Offset(1, 0)
With auditRecord
    .Value = cellAddress 'Address of change
    .Offset(0, 1).Value = newValue 'new value
    .Offset(0, 2).Value = oldValue 'previous value
    .Offset(0, 3).NumberFormat = "dd mm yyyy hh:mm:ss"
    .Offset(0, 3).Value = Now 'time of change
    .Offset(0, 4).Value = Application.UserName 'user who made change
    .Offset(0, 5).Value = Me.Range("D" & Split(cellAddress, "$")(2)).Value
End With
Write_Change = True
Exit Function
errHandler:
Write_Change = False
Debug.Print "Error number: " & Err.Number
Debug.Print "Error descr: " & Err.Description
End Function

Answer 1

在Write_Change中，您可以测试cellAddress，看看它是否是您想写的内容。例如，如果您只想在A1:F50中捕获更改，则可以写：

If Not(Intersect(Me.Range(cellAddress), me.Range("A1:F50")) IS NOTHING) Then
    Write_Change = False
    Exit Function
End If

或者那些东西。如果您的可接受单元格范围由多个区域组成，您可以查看UNION函数将它们拼接成一个可以使用IF Not(Intersect() Is Nothing))逻辑进行测试的范围。

在特定单元格上应用VBA代码

1 个答案: