Events 如何使用Excel VBA制作外部日志？

代码已更新，以引用以下更改

此日志系统为Excel创建一个名为log.txt的外部文档，它将在log.txt文件中创建一行，如下所示：

上午11:27:20 Matthew Ridge将手机$55从ss改为

这不会告诉您是否有人在工作表中输入了一行新的代码，但如果代码需要答案，它会告诉您答案所在的单元格。以下代码适用于Mac和PC系统。如果人们发现没有，请说

这段代码是在这里的人和其他形式的帮助下创建的，因此我不能单独拥有该文档，但我可以拥有该概念的所有权。因此，感谢那些帮助过我的人，在我看来，没有这些，现在就不会有一个可行的Excel日志系统；）

顺便说一句，在任何人发疯并询问此代码的去向之前，一般/新的最终用户并不清楚这一点。您需要转到打开它，单击Visual Basic，当新窗口打开时，查找Microsoft Excel对象；该文件夹下应该是您的工作簿。您可以通过双击希望代码所在的工作表，将其放在此工作簿下或任何工作表内

一旦工作表在右侧面板上打开，您将看到选项Explicit，如果您没有，最好通过确保选中Require变量声明来激活它。这将再次在Visual Basic窗口中找到，并遵循以下路径：

工具->选项->编辑器

如果它被检查了，那么你就不用担心，如果没有，那么你就检查它。OptionExplicit对您的代码来说是一件好事，它迫使您声明变量，这是一个很好的开始

验证后，您可以复制下面的代码，将其粘贴到工作簿中，或根据需要粘贴到特定的工作表中

版本2.01

选项显式
模糊先前值
私有子工作表_更改（ByVal目标作为范围）
Dim sLogFileName为字符串，nFileNum为长，sLogMessage为字符串
sLogFileName=ThisWorkbook.Path&Application.PathSeparator&“Log.txt”
错误恢复下一步“打开错误处理”
如果Target.Value PreviousValue，则
'检查我们是否有错误
如果错误编号=13，则
上一个值=0
如果结束
'关闭错误处理
错误转到0
sLogMessage=Now&Application.UserName&“已更改单元格”&Target.Address_
&“from”&PreviousValue&“to”&Target.Value
nFileNum=FreeFile的下一个文件号
打开sLogFileName以附加为#nFileNum'如果文件不存在，则创建该文件
打印#nFileNum，sLogMessage'附加信息
关闭#nFileNum“关闭文件”
如果结束
端接头
专用子工作表\u选择更改（ByVal目标作为范围）
PreviousValue=目标（1）。值
端接头

随着时间的推移，我将尝试更新此代码，以便在我认为合适的情况下为其添加更多功能

---

再次感谢所有的帮助，我们非常感谢能够做到这一点。

问题是，当您输入合并单元格时，输入到先前值（在

工作表\u SelectionChange

中）的值是所有合并单元格的数组，您无法与新值进行比较。当编辑时触发

工作表\u Change

时，目标仅为合并范围的左上角单元格。让我们跟踪合并区域的单元格。将您的

工作表\u selection change

替换为以下内容：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    PreviousValue = Target(1).Value
End Sub

---

免责声明：这是在Excel for Mac 2011上测试的，因为我目前无法访问Excel for Windows，但我非常确信它也能在Excel for Windows上工作。

Matt Ridge-我知道你要求一次完成多个更改的解决方案，我只晚了3年，但现在是：）。 我对原始代码做了一些轻微的修改，但这将处理合并的单元格并记录对单元格的多个更改

选项显式 Dim PreviousValue（）

私有子工作表_更改（ByVal目标作为范围） Dim sLogFileName为字符串，nFileNum为长，sLogMessage为字符串，r为长

sLogFileName=thiswoolk.Path&Application.pathselector&“Log.txt”
'检查所有单元格是否有变化，不包括D4 D5 E5 M1等
对于r=1到Target.Count
如果目标（r）.值先前的值（r）和相交（目标（r），范围（“D4，D5，E5，M1”）为零，则
'检查我们是否有错误
如果错误编号=13，则
上一个值（r）=0
如果结束
'关闭错误处理
'在出现错误时转到0
'将数据记录到.txt文件中
sLogMessage=Now&“”&Application.UserName&“已更改单元格”&Target（r）.Address\u
&“在”&ActiveSheet.Name&“从”&“&PreviousValue（r）&”到“&Target（r）.Value&”&“在工作簿中”&ThisWorkbook.Path&“&ActiveWorkbook.Name”
nFileNum=FreeFile的下一个文件号
打开sLogFileName以附加为#nFileNum'如果文件不存在，则创建该文件
打印#nFileNum，sLogMessage'附加信息
关闭#nFileNum“关闭文件”
如果结束
下一个r
端接头
专用子工作表\u选择更改（ByVal目标作为范围）
我想我会坚持多久
'查看最上面的单元格（如果单元格合并）
Redim PreviousValue（1到Target.Count）
对于i=1的目标。计数
以前的值（i）=目标（i）.值
接下来我
端接头

一年后，我修改了Matthew的代码-现在它也通过复制/粘贴或跟踪鼠标来跟踪更改，谢谢Matthew的好主意！：

'Paste this into a Module:

Option Explicit

'SheetArray to hold the old values before any change is made
Public aSheetArr() As Variant


'helperfunctions for last row and last col of a given sheet:

Function LastRow(sh As Worksheet)
'get last row of a given worksheet
sh.EnableAutoFilter = False
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            LookAt:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
'get last col of a given worksheet
sh.EnableAutoFilter = False
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            LookAt:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function


'Paste this into the workbook_Open method of your workbook (initializing the sheetarray)
Option Explicit

Private Sub Workbook_Open()
Dim lCol As Long
Dim lRow As Long

Dim wks As Worksheet
Set wks = Sheets(1)

lCol = LastCol(wks)
lRow = LastRow(wks)


aSheetArr = wks.Range(wks.Cells(1, 1), wks.Cells(lRow, lCol)) 'read the Range from the whole Sheet into the array


End Sub



'Paste this into the tablemodule - area where you want to log the changes:


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'logging all the changes in a worksheet - also the copy/past's and track down's over ceveral cells

    Dim sLogFileName As String, nFileNum As Long, sLogMessage As String, r As Long


sLogFileName = ThisWorkbook.Path & Application.PathSeparator & "Log.txt"


 'Check all cells for changes, excluding D4 D5 E5 M1 etc
For r = 1 To Target.Count
    'compare each cell with the values from the old cell
    If Target(r).value <> aSheetArr(Target(r).Row, Target(r).Column) Then
         ' Check if we have an error
        If Err.Number = 13 Then
            PreviousValue(r) = 0

        End If
         ' Turn off error handling
         'On Error GoTo 0
         'log data into .txt file
        sLogMessage = Now & " " & Application.UserName & " changed cell " & Target(r).Address _
        & " in " & ActiveSheet.Name & " from " & "'" & aSheetArr(Target(r).Row, Target(r).Column) & "' to '" & Target(r).value & "'"

        'set the values in the array to the changed ones
        aSheetArr(Target(r).Row, Target(r).Column) = Target(r).value

        nFileNum = FreeFile ' next file number
        Open sLogFileName For Append As #nFileNum ' create the file if it doesn't exist
        Print #nFileNum, sLogMessage ' append information
        Close #nFileNum ' close the file
    End If
Next r
End Sub

“将其粘贴到模块中：
选项显式
'SheetArray以在进行任何更改之前保留旧值
Public asheetar（）作为变体
'帮助功能
Option Explicit 
Dim PreviousValue() 


Private Sub Worksheet_Change(ByVal Target As Range) 
    Dim sLogFileName As String, nFileNum As Long, sLogMessage As String, r As Long 


sLogFileName = ThisWorkbook.Path & Application.PathSeparator & "Log.txt" 


 'Check all cells for changes, excluding D4 D5 E5 M1 etc
For r = 1 To Target.Count 
    If Target(r).Value <> PreviousValue(r) And Intersect(Target(r), Range("D4,D5,E5,M1")) Is Nothing Then 
         ' Check if we have an error
        If Err.Number = 13 Then 
            PreviousValue(r) = 0 

        End If 
         ' Turn off error handling
         'On Error GoTo 0
         'log data into .txt file
        sLogMessage = Now & " " & Application.UserName & " changed cell " & Target(r).Address _ 
        & " in " & ActiveSheet.Name & " from " & "'" & PreviousValue(r) & "' to '" & Target(r).Value & "'" & " in workbook " & ThisWorkbook.Path & " " & ActiveWorkbook.Name 

        nFileNum = FreeFile ' next file number
        Open sLogFileName For Append As #nFileNum ' create the file if it doesn't exist
        Print #nFileNum, sLogMessage ' append information
        Close #nFileNum ' close the file
    End If 
Next r 
End Sub 


Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
Dim i As Long 

 'looks at the uppermost cell (incase cells are merged)

Redim PreviousValue(1 To Target.Count) 
For i = 1 To Target.Count 
    PreviousValue(i) = Target(i).Value 
Next i      
    End sub

'Paste this into a Module:

Option Explicit

'SheetArray to hold the old values before any change is made
Public aSheetArr() As Variant


'helperfunctions for last row and last col of a given sheet:

Function LastRow(sh As Worksheet)
'get last row of a given worksheet
sh.EnableAutoFilter = False
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            LookAt:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
'get last col of a given worksheet
sh.EnableAutoFilter = False
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            LookAt:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function


'Paste this into the workbook_Open method of your workbook (initializing the sheetarray)
Option Explicit

Private Sub Workbook_Open()
Dim lCol As Long
Dim lRow As Long

Dim wks As Worksheet
Set wks = Sheets(1)

lCol = LastCol(wks)
lRow = LastRow(wks)


aSheetArr = wks.Range(wks.Cells(1, 1), wks.Cells(lRow, lCol)) 'read the Range from the whole Sheet into the array


End Sub



'Paste this into the tablemodule - area where you want to log the changes:


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'logging all the changes in a worksheet - also the copy/past's and track down's over ceveral cells

    Dim sLogFileName As String, nFileNum As Long, sLogMessage As String, r As Long


sLogFileName = ThisWorkbook.Path & Application.PathSeparator & "Log.txt"


 'Check all cells for changes, excluding D4 D5 E5 M1 etc
For r = 1 To Target.Count
    'compare each cell with the values from the old cell
    If Target(r).value <> aSheetArr(Target(r).Row, Target(r).Column) Then
         ' Check if we have an error
        If Err.Number = 13 Then
            PreviousValue(r) = 0

        End If
         ' Turn off error handling
         'On Error GoTo 0
         'log data into .txt file
        sLogMessage = Now & " " & Application.UserName & " changed cell " & Target(r).Address _
        & " in " & ActiveSheet.Name & " from " & "'" & aSheetArr(Target(r).Row, Target(r).Column) & "' to '" & Target(r).value & "'"

        'set the values in the array to the changed ones
        aSheetArr(Target(r).Row, Target(r).Column) = Target(r).value

        nFileNum = FreeFile ' next file number
        Open sLogFileName For Append As #nFileNum ' create the file if it doesn't exist
        Print #nFileNum, sLogMessage ' append information
        Close #nFileNum ' close the file
    End If
Next r
End Sub