Audit Trail - VBA - Tracking related cells

[richi5000]

Hi MrExcel Community,

It's my first post here - so "Hello"

Currently I'm using this Audit Trail Macro to track cell changes in multiple sheets:

Option Explicit
Dim sOldAddress As String
Dim vOldValue As Variant
Dim sOldFormula As String
Private Sub Workbook_TrackChange(Cancel As Boolean)
 
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
sh.PageSetup.LeftFooter = "&06" & ActiveWorkbook.FullName & vbLf & "&A"
Next sh
End Sub
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
'''''''''''''''''''''''''''''''''''''''''''''
'Thanks to lenze for getting me started on this project ([URL]http://vbaexpress.com/kb/getarticle.php?kb_id=909[/URL])
'http://www.mrexcel.com/forum/excel-questions/376400-vba-ignoring-exit-sub-select-all.html?referrerid=76744 'Thanks to Colin_L
'Adapted by Mark Reierson 2009
'''''''''''''''''''''''''''''''''''''''''''''
 
Dim wSheet As Worksheet
Dim wActSheet As Worksheet
Dim iCol As Integer
Set wActSheet = ActiveSheet
 
 
On Error Resume Next ' This Error-Resume-Next is only to allow the creation of the tracker sheet.
Set wSheet = Sheets("Tracker")
'**** Add the tracker Sheet if it does not exist ****
 
If wSheet Is Nothing Then
Set wActSheet = ActiveSheet
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Tracker"
End If
On Error GoTo 0
'**** End of specific error resume next
 
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
 
With Sheets("Tracker")
'******** This bit of code moves the tracker over a column when the first columns are full**'
If .Cells(1, 1) = "" Then '
iCol = 1 '
Else '
iCol = .Cells(1, 256).End(xlToLeft).Column - 7 '
If Not .Cells(65536, iCol) = "" Then '
iCol = .Cells(1, 256).End(xlToLeft).Column + 1 '
End If '
End If '
'********* END *****************************************************************************'
.Unprotect Password:="xxxxx"
 
'******** Sets the Column Headers **********************************************************
If LenB(.Cells(1, iCol).Value) = 0 Then
.Range(.Cells(1, iCol), .Cells(1, iCol + 7)) = Array("Cell Changed", "Old Value", _
"New Value", "Old Formula", "New Formula", "Time of Change", "Date of Change", "User")
.Cells.Columns.AutoFit
End If
With .Cells(.Rows.Count, iCol).End(xlUp).Offset(1)
 
.Value = sOldAddress
.Offset(0, 1).Value = vOldValue
.Offset(0, 3).Value = sOldFormula
 
If Target.Count = 1 Then
.Offset(0, 2).Value = Target.Value
If Target.HasFormula Then .Offset(0, 4).Value = "'" & Target.Formula
End If
 
.Offset(0, 5) = Time
.Offset(0, 6) = Date
.Offset(0, 7) = Application.UserName
.Offset(0, 7).Borders(xlEdgeRight).LineStyle = xlContinuous
End With
 
.Protect Password:="xxxxx"
 
End With
ErrorExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
 
wActSheet.Activate
Exit Sub
 
ErrorHandler:
'any error handling you want
'Debug.Print "We have an error"
Resume ErrorExit
 
End Sub
 
Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
 
With Target
sOldAddress = .Address(external:=True)
 
If .Count > 1 Then
 
vOldValue = "Multiple Cell Select"
sOldFormula = vbNullString
 
Else
 
vOldValue = .Value
If .HasFormula Then
sOldFormula = "'" & Target.Formula
Else
sOldFormula = vbNullString
End If
End If
End With
End Sub

As this macro only tracks the cell-reference, it becomes useless (for my need) as soon as the data in the sheets is sorted. So my question:

How can I additionally track the content of specific, corresponding cells, e.g. the ID in the first column and the column header in the first row?

For example:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]ID
[/TD]
[TD]value 1
[/TD]
[TD]value 2
[/TD]
[TD]value 3
[/TD]
[TD]value 4
[/TD]
[/TR]
[TR]
[TD]001
[/TD]
[TD]1
[/TD]
[TD][/TD]
[TD]110
[/TD]
[TD]cccd
[/TD]
[/TR]
[TR]
[TD]002
[/TD]
[TD]x
[/TD]
[TD]b
[/TD]
[TD]2
[/TD]
[TD]29
[/TD]
[/TR]
</tbody>[/TABLE]


[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]ID
[/TD]
[TD]value 1
[/TD]
[TD]value 2
[/TD]
[TD]value 3
[/TD]
[TD]value 4
[/TD]
[/TR]
[TR]
[TD]001
[/TD]
[TD]x
[/TD]
[TD][/TD]
[TD]110
[/TD]
[TD]cccd
[/TD]
[/TR]
[TR]
[TD]002
[/TD]
[TD]x
[/TD]
[TD]b
[/TD]
[TD]2
[/TD]
[TD]29
[/TD]
[/TR]
</tbody>[/TABLE]


So when I change value 1 in the 2nd row to "x" (in red), the tracker should store the ID "001" & the header "value 1".

Right now it stores this:


[TABLE="width: 500"]
<tbody>[TR]
[TD]Cell Changed
[/TD]
[TD]Old Value
[/TD]
[TD]New Value
[/TD]
[TD]Old Formula
[/TD]
[TD]New Formula
[/TD]
[TD]Time
[/TD]
[TD]Date
[/TD]
[TD]User
[/TD]
[/TR]
[TR]
[TD][Test.xlsm]Sheet1'!$I$11
[/TD]
[TD]1
[/TD]
[TD]x
[/TD]
[TD][/TD]
[TD][/TD]
[TD]10:00:01
[/TD]
[TD]24.11.2017
[/TD]
[TD]Richie
[/TD]
[/TR]
</tbody>[/TABLE]

And I would need this:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Cell Changed
[/TD]
[TD]ID
[/TD]
[TD]Column
[/TD]
[TD]Old Value
[/TD]
[TD]New Value
[/TD]
[TD]Old Formula
[/TD]
[TD]New Formula
[/TD]
[TD]Time
[/TD]
[TD]Date
[/TD]
[TD]User
[/TD]
[/TR]
[TR]
[TD][Test.xlsm]Sheet1'!$I$11
[/TD]
[TD]001
[/TD]
[TD]value 1
[/TD]
[TD]1
[/TD]
[TD]x
[/TD]
[TD][/TD]
[TD][/TD]
[TD]10:00:01
[/TD]
[TD]24.11.2017
[/TD]
[TD]Rich
[/TD]
[/TR]
</tbody>[/TABLE]


Do you have any ideas how this could be accomplished? I'm thankful for every tipp I can get.

Richie

 

[richi5000]

*push*

 

[richi5000]

Anybody?

 

[richi5000]