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.
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) “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.
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
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
