The code has been updated to reference the changes below.
This log system create an external document for Excel called Log.txt, it will create a line in the log.txt
one year later i modified the Code from Matthew - now it tracks changes by copy/paste or tracking down the mouse too, thanks Matthew for the good idea!:
'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