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

在特定单元格上应用VBA代码,vba,excel,Vba,Excel,我正在使用审计跟踪记录第一页上的变更,并将其记录在第二页上。代码运行良好,但是,我想限制代码仅在特定单元格上运行,即(A1:L100)。原因是我有一些从M列开始的工作,所以我不想记录这些工作中的任何移动。对以下代码添加/修改内容的任何建议: Option Explicit Public dArr As Variant Private Sub Worksheet_Calculate() Dim nArr As Variant Dim auditRecord As Range Dim i As Lo

我正在使用审计跟踪记录第一页上的变更,并将其记录在第二页上。代码运行良好,但是,我想限制代码仅在特定单元格上运行,即(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
选项显式
作为变体的公共dArr
专用子工作表_Calculate()
Dim nArr作为变体
将记录作为范围
我想我会坚持多久
Dim j尽可能长
nArr=Me.UsedRange
'查找对已使用范围的更改
对于i=1到UBound(dArr,2)
对于j=1至UBound(dArr,1)
如果nArr(j,i)dArr(j,i)那么
'写入范围
如果不写更改(dArr(j,i)、nArr(j,i)、Me.Cells(j,i).Address),那么
MsgBox“未记录更改”,vbInformation
如果结束
如果结束
下一个j
接下来我
抹掉那尔,达尔
dArr=Me.UsedRange
端接头
私有子工作表_更改(ByVal目标作为范围)
暗淡单元格作为范围
将值作为变量
对于目标中的每个单元格
出错时继续下一步
oldValue=vbNullString
oldValue=dArr(Cell.Row,Cell.Column)
错误转到0
如果是oldValue单元格.Value,则
如果不写更改(oldValue、Cell.Value、Cell.Address),则
MsgBox“未记录更改”,vbInformation
如果结束
如果结束
下一个细胞
出错时继续下一步
抹黑
错误转到0
dArr=Me.UsedRange
端接头
专用子工作表\u选择更改(ByVal目标作为范围)
dArr=Me.UsedRange
端接头
公共函数Write_Change(oldValue、newValue、cellAddress作为字符串)作为布尔值
将记录作为范围
关于错误转到错误处理程序
Set auditRecord=Sheets(“ChangeHistory”).Range(“A:A”).Find(“*”,searchdirection:=xlPrevious).偏移量(1,0)
有审计记录
.Value=cellAddress的更改地址
.Offset(0,1).Value=newValue'新值
.偏移量(0,2).值=旧值“以前的值”
.Offset(0,3).NumberFormat=“dd-mm-yyy-hh:mm:ss”
.Offset(0,3).Value=现在的“更改时间”
.Offset(0,4).Value=Application.UserName'进行更改的用户
.Offset(0,5).Value=Me.Range(“D”)和Split(cellAddress,“$”)(2)).Value
以
Write_Change=True
退出功能
错误处理程序:
Write_Change=False
调试。打印“错误号:&错误号”
Debug.Print“Error descr:”错误描述(&Err.Description)
端函数

Write\u Change
中,您可以测试您的
手机地址
,看看它是否是您想写的内容。例如,如果您只想捕获
A1:F50中的更改,您可以编写:

If Not(Intersect(Me.Range(cellAddress), me.Range("A1:F50")) IS NOTHING) Then
    Write_Change = False
    Exit Function
End If
或者类似的东西。如果可接受的单元格区域由多个区域组成,则可以检查
UNION
函数,将它们缝合到单个区域中,如果没有(Intersect()为Nothing))
逻辑,则可以使用该
进行测试