Excel Audit Trail

Custom Excel Worksheet Protection
The client called with a query: “I am trying to figure how I can make the attached spreadsheet highlight with yellow fill any change made by the user after the sheet is refreshed. The idea is the user would refresh the data from our database and if they wanted to make a change they would make the revision in the file which would automatically turn the cell yellow with the change.

 

The user would make the revision in the file which would automatically turn the cell yellow with the change.Then after they make the change, they would hit a button that would generate an email summarizing the change…. Not sure that is possible”.
I love challenges like this because I immediately know it is more than possible.  It also occurs to me as an ex auditor that this is essential an audit trail or change log.
The Track Change (Legacy) Function The track changes function is not on the menu but you can add it by customizing the ribbon. The problem is this Track Changes doesnt work with the shared workbooks. Excel will actually popup a box and say you should remove it.  That whole ‘legacy” designation is troubling so I decided to use VBA to create a custom solution.  
Create two additional sheets:
1) “Copy” where you will keep a copy ‘untouched’ data.  I update this every time new data is brought in.  It is what we test against to see if there has been a change.
2) “Master” where all the changes are stored and Email reference data is kept

 

1 Sub change_tracker()
2 ' creates running list of changes on the 'Master' sheet
3
4 Dim sMisc As String, Myrange As Range
5 Dim sStart As String: sStart = ActiveSheet.Name
6 Dim cell As Range
7
8 ' Clear and update the copy sheet ...
9 Application.ScreenUpdating = False
10 Worksheets("Copy").Visible = True: Sheets("Copy").Activate
11 Range("a1:CZ2000").Clear
12
13 ' take a copy of the original data ...
14 Sheets(sStart).Activate
15 Range("A4:CZ2000").Select
16 Selection.Copy
17
18 'open, clear, then paste values only
19 Sheets("Copy").Activate
20 Range("A4").Select
21 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
22 :=False, Transpose:=False
23 Sheets(sStart).Activate: Worksheets("Copy").Visible = False
24 Range("A1").Select
25
26 ' Clear and update the changes on the master sheet ...
27 Worksheets("Master").Visible = True: Sheets("Master").Activate
28 sMisc = "A" & Range("Starter").Row & ":k1000"
29 Range(sMisc).Clear
30 Worksheets("Master").Visible = False
31
32 ' Clear prior changes yellow on sheet to be tracked ...
33 Set Myrange = Range("a1:CZ2000")
34 For Each cell In Myrange
35 If cell.Interior.Color = 65535 Then
36 With cell.Interior
37 .Pattern = xlNone
38 .TintAndShade = 0
39 .PatternTintAndShade = 0
40 End With
41 End If
42 Next cell
43
44
45 Application.ScreenUpdating = False
46
47 End Sub

Code Snippets by Ray Mills
This is my method - Always thoroughly test and retest your code!

This first section of code above is run after the User imported new data.  It sets up to clean up in preparation of recording New changes. 1. It clears the old Data in the “copy spreadsheet 2. It copies ‘values only’ of the data to be tracked to the “copy” sheet 3. It clears the old changes list and in the Master sheet 4. It resets all the old highlighted cells on the sheet where the tracking occurs.
1 Private Sub Worksheet_Change(ByVal Target As Range)
2 ' this is the code for the change event on the spreadsheet we are tracking
3
4 If booDBUpdate = False Then
5 Dim cell As Range
6
7 For Each cell In Target
8 Call Change_Recorder(cell)
9 Next cell
10 End If
11
12 End Sub

Code Snippets by Ray Mills
This is my method - Always thoroughly test and retest your code!

Below I have added a change event to the worksheet we are monitoring. You will note that it passes changes to the Change_Recorder subroutine cell by cell  Our user could change more than one cell at a time.the
1 Sub Change_Recorder(Target As Range)
2 ' Writes changes to the Master worksheet …
3
4 Dim x As Integer
5 x = Worksheets("Master").Range("Starter").Row
6
7 Do Until Worksheets("Master").Cells(x, 1) = ""
8 x = x + 1
9 Loop
10
11 With Worksheets("Master")
12
13 If Target.Value <> Empty Or Worksheets("Copy").Range(Target.AddressLocal).Value <> Empty Then
14 If x = .Range("Starter").Row Then
15 .Cells(x, 1) = 1
16 Else
17 .Cells(x, 1) = .Cells(x - 1, 1) + 1
18 End If
19
20 .Cells(x, 2) = Format(Now, "MM/DD/YY") ' Date
21 .Cells(x, 3) = Format(Now, "HH:MM AM/PM") ' Time
22 .Cells(x, 4) = Application.UserName ' Who
23 .Cells(x, 5) = Cells(Target.Row, 2) ' BR#
24 .Cells(x, 6) = Cells(5, Target.Column) ' Revised Order
25 .Cells(x, 7) = Target.Value ' New value
26 .Cells(x, 8) = Worksheets("Copy").Range(Target.Address).Value ' Current DB
27 Else
28 'Exit Sub
29 End If
30
31
32 ' highlight changes ...
33 If Range(Target.Address).Value <> Worksheets("Copy").Range(Target.Address).Value Then
34 With Range(Target.Address).Interior
35 .Color = 65535
36 End With
37 Else
38 With Range(Target.Address).Interior
39 .Pattern = xlNone
40 .TintAndShade = 0
41 .PatternTintAndShade = 0
42 End With
43 End If
44
45 End With
46
47 End Sub

Code Snippets by Ray Mills
This is my method - Always thoroughly test and retest your code

If you recall from the above changes are passed from the change event, one cell at a time. This code first finds the first empty line in list of changes. The Range “Starter” is the range name of the first line first cell the the change list we are building. 
It first checks to see if the value is different than the original and if so it colors the cell yellow.
1 Sub sendUpdates()
2 ' creates the update bundle [sMsg] and sends it
3
4 Dim x As Integer, i As Integer
5 Dim sMisc As String, sField As String
6 ' test if there are updates ...
7 If Worksheets("Master").Range("Starter").Value = "" Then
8 MsgBox "No updates have been identified", vbCritical, "No Action Taken"
9 Exit Sub
10 End If
11
12 sMisc = sMisc & "<html>" & vbNewLine
13 sMisc = sMisc & "<headl>" & vbNewLine
14 sMisc = sMisc & "</headl>" & vbNewLine
16 sMisc = sMisc & "<stylel>" & vbNewLine
17 sMisc = sMisc & "table {" & vbNewLine
18 sMisc = sMisc & " font-family: arial, sans-serif;" & vbNewLine
19 sMisc = sMisc & "font-size: 15px;" & vbNewLine
20 sMisc = sMisc & " border-collapse: collapse;" & vbNewLine
21 sMisc = sMisc & " width: 100%;" & vbNewLine
22 sMisc = sMisc & "}" & vbNewLine
23 sMisc = sMisc & "" & vbNewLine
24 sMisc = sMisc & "td, th {" & vbNewLine
25 sMisc = sMisc & " border: 1px solid #dddddd;" & vbNewLine
26 sMisc = sMisc & " text-align: left;" & vbNewLine
27 sMisc = sMisc & " padding: 8px;" & vbNewLine
28 sMisc = sMisc & "}" & vbNewLine
29 sMisc = sMisc & "" & vbNewLine
30 sMisc = sMisc & "tr:nth-child(even) {" & vbNewLine
31 sMisc = sMisc & " background-color: #dddddd;" & vbNewLine
32 sMisc = sMisc & "}" & vbNewLine
33 sMisc = sMisc & "" & vbNewLine
34 sMisc = sMisc & "" & vbNewLine
35 sMisc = sMisc & "<h3>Updates</h3>" & vbNewLine
36 sMisc = sMisc & "<table>" & vbNewLine
37
38 ' Add Table headers ...
39 With Worksheets("Master")
40 i = .Range("Starter").Row - 1
41
42 sMisc = sMisc & "<tr>" & vbNewLine
43 For x = 1 To 8
44 sMisc = sMisc & "<th>" & .Cells(i, x) & "</th>"
45 Next x
46 sMisc = sMisc & "</tr>" & vbNewLine
47
48 'add changes ...
49
50 i = .Range("Starter").Row
51 Do Until .Cells(i, 1) = Empty
52 sMisc = sMisc & <tr> & vbNewLine: j = 0
53 For x = 1 To 8
54 If x <> 3 Then
55 sMisc = sMisc & "<td>" & .Cells(i, x) & "</td>"
56 Else
57 sMisc = sMisc & "<td>" & Format(.Cells(i, x), "HH:MM AM/PM") & "</td>"
58 End If
59 Next x
60 sMisc = sMisc & "</tr>" & vbNewLine
61 i = i + 1
62 Loop
63
64 End With
65
66 sMisc = sMisc & "</table>" & vbNewLine
67 sMisc = sMisc & </body>" & vbNewLine
68 sMisc = sMisc & "</html>"
69
70 Call Send_Email(Worksheets("Master").Range("c2").Value, sMisc, Worksheets("Master").Range("c1").Value)
71
72 End Sub

Code Snippets by Ray Mills
This is my solution - Always thoroughly test and retest your code

This code puts the change list to gether and sends it to the send email module that uses Outlook to send the update information
1 Sub Send_Email(sAddressee As String, sMsg As String, sSubject As String)
2 ' creates an instance of outlook and sends the changes as a table
3
4 'Setting up the Excel variables.
5 Dim olApp As Object
6 Dim olMailItm As Object
7 Dim iCounter As Integer
8 Dim Dest As Variant
9 Dim SDest As String
10
11 'Create the Outlook application and the empty email.
12 Set olApp = CreateObject("Outlook.Application.16")
13 Set olMailItm = olApp.CreateItem(0)
14
15 With olMailItm
16 .Display
17 .HTMLBody = sMsg
18 .To = sAddressee
19 '.CC = "sdf@gamil.com"
20 '.BCC = "hello@gamil.com;hi@gmail.com"
21 .Subject = sSubject
22 '.Attachments = ThisWorkbook
23 '.Send
24 End With
25
26 Set OApp = Nothing
27
28 End Sub

Code Snippets by Ray Mills
This is my solution - Always thoroughly test and retest your code

This is the outlook mailer code subroutine and is straight forward.
If you were able to utilize what you learned here or improve the code,
please leave a comment Here  

If you enjoyed this post or found it helpful and would like to say hello
and buy me a cup of coffee Click here
Raymond Mills MBA, MS
Raymond Mills, M.B.A., M.S.  has spent over 20 years of his career as Accountant, Investment Bank and Credit Card Technical Auditor/ Data Analyst.  His specialty was using Excel to get Big Databases including Teradata, Oracle,  Squel Server and Sybase to give up their secrets. Ray has said “I love nothing better than using VBA to unleash the power of Microsoft Office.” You can contact Ray @ 484 574-3190 or by emailing him Here

If you have a challenge with Excel, Access or Word and would like to speak with Ray,   You can get his contact details by clicking here: Contact Me
Tagged , . Bookmark the permalink.

Comments are closed.