Track Changes via Macro

ManSim · Mar 23, 2010

Hi all,
I am brandnew to VBA but learn a bit more every day. Now I have the following problem that needs your help:
I have about 15 different excel inventories and need to check every Monday if changes were made in the last week. All files are shared hence "tracking changes" is basically possible.
Now instead of clicking the mouse so many times I attempted to start recording a macro to ease my work. The result was the following code:
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com

ffice

ffice" /><o

> </o

>
Sub TrackChanges()
'
' TrackChanges Macro
'
<o

> </o

>
'
With ActiveWorkbook
.HighlightChangesOptions When:="15.03.2010"
.ListChangesOnNewSheet = True
.HighlightChangesOnScreen = True
End With
End Sub
<o

> </o

>
<o

> </o

>
Unfortunately this macro does not really work - nothing happens! What is wrong with this?
<o

> </o

>
PS. At a later stage I want to replace the hard coded date with an input msgbox...

Much appreciate any comment.
Thanks in advance

arkusM · Mar 26, 2010

Place this code in "ThisWorkbook"
It will track all changes made anywher in the workbook and places the changes on a tab called "tracker" it also tracks formula changes.

Code:

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/showthread.php?t=376400&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
 
'Precursor Exits
'Other conditions that you do not want to tracke could be added here
If vOldValue = "" Then Exit Sub 'If you comment out this line *every* entry will be recorded
 
'Continue
 
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:="Secret"
 
'******** 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:="Secret" 'Uncomment to protect the "tracker tab"
 
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

memoney77 · Mar 29, 2010

Dear ArkusM, I have been looking for a macro like this for some time. Works great. I am a beginner to VBA, which is why I am having problems tweaking your macro to fit my circumstances. I only need a few minor changes to get it working and would greatly appreciate your help.

1. I am using a spreadsheet with API feeds that update many cells, so I would like to track changes in only column "S" and not the entire sheet.
2. If the value of a cell in column "S" changes (thru an API feed) I would like it to take the difference between the "Old Value" and "New Value", and then multiply it by the cell in column "T" of the corresponding row.

A million thanks.

memoney77

arkusM · Mar 29, 2010

memoney77 said:
Dear ArkusM, I have been looking for a macro like this for some time. Works great. I am a beginner to VBA, which is why I am having problems tweaking your macro to fit my circumstances. I only need a few minor changes to get it working and would greatly appreciate your help.

1. I am using a spreadsheet with API feeds that update many cells, so I would like to track changes in only column "S" and not the entire sheet.
2. If the value of a cell in column "S" changes (thru an API feed) I would like it to take the difference between the "Old Value" and "New Value", and then multiply it by the cell in column "T" of the corresponding row.

A million thanks.

memoney77

Copy and paste the Whole Bit.
You will have to Change the Sheet reference for the target sheet I assumed "Sheet1". The macro fuctions as previously posted I only ADDED the functions you requested.

Code:

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/showthread.php?t=376400&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
    'Precursor Exits
    'Other conditions that you do not want to tracke could be added here
    If vOldValue = "" Then Exit Sub    'If you comment out this line *every* entry will be recorded
[COLOR=seagreen]    
[/COLOR][COLOR=red]    'ADDED AS REQUESTED ***************************************
    If Not Target.Column() = 19 Then Exit Sub
    'Continue
    'END REQUEST **********************************************
[/COLOR]    
    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
[COLOR=red]    'ADDED THIS TO MULTIPLY ***************************************
    With Sheet1
        Target.Offset(0, 1).Value = vOldValue * Target.Value
    End With
    'END ADD ******************************************************[/COLOR]
    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:="Secret"
        '******** 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:="Secret" 'Uncomment to protect the "tracker tab"
    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

memoney77 · Mar 29, 2010

Thanks for your help and quick reply. The only issue I'm having now is the multiplication part of the code.

"2. If the value of a cell in column "S" changes (thru an API feed) I would like it to take the difference between the "Old Value" and "New Value", and then multiply it by the cell in column "T" of the corresponding row."

The resulting value needs to be added to a column on the tracker sheet. Its seems to be replacing the value in column "T" on sheet1.

Thanks again

arkusM · Mar 29, 2010

memoney77 said:
Thanks for your help and quick reply. The only issue I'm having now is the multiplication part of the code.

"2. If the value of a cell in column "S" changes (thru an API feed) I would like it to take the difference between the "Old Value" and "New Value", and then multiply it by the cell in column "T" of the corresponding row."

The resulting value needs to be added to a column on the tracker sheet. Its seems to be replacing the value in column "T" on sheet1.

Thanks again

Yeah, I was just rereading and repsonding LOL. Sorry about that.
Did you want an additional column for the multiplication result?

memoney77 · Mar 29, 2010

No problem, A new column on the tracker sheet for the multiplication result would be great. I can't thank you enough!!

arkusM · Mar 29, 2010

Sorry about the misunderstanding....
Try this out. NOTE there is not error checking, if a value other than a number is input you'll get not result.

Cheers,
Mark

Code:

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_Open()
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
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/showthread.php?t=376400&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
    'Precursor Exits
    'Other conditions that you do not want to tracke could be added here
    If vOldValue = "" Then Exit Sub    'If you comment out this line *every* entry will be recorded
    'ADDED AS REQUESTED ***************************************
    If Not Target.Column() = 19 Then Exit Sub
    'Continue
    'END REQUEST **********************************************
    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 - 8    '
            If Not .Cells(65536, iCol) = "" Then    '
                iCol = .Cells(1, 256).End(xlToLeft).Column + 1    '
            End If    '
        End If    '
        '********* END *****************************************************************************'
        .Unprotect Password:="Secret"
        '******** Sets the Column Headers **********************************************************
        If LenB(.Cells(1, iCol).Value) = 0 Then
            .Range(.Cells(1, iCol), .Cells(1, iCol + 8)) = Array("Cell Changed", "Old Value", _
                                                                 "New Value", "Old Formula", "New Formula", "Multiplied", "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
            On Error Resume Next
            'ADDED THIS TO MULTIPLY ***************************************
            .Offset(0, 5) = (vOldValue - Target.Value) * Target.Offset(0, 1).Value
            'END ADD ******************************************************
            On Error GoTo ErrorHandler
            .Offset(0, 6) = Time
            .Offset(0, 7) = Date
            .Offset(0, 8) = Application.UserName
            .Offset(0, 8).Borders(xlEdgeRight).LineStyle = xlContinuous
        End With
        '.Protect Password:="Secret" 'Uncomment to protect the "tracker tab"
    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

memoney77 · Mar 29, 2010

Mark, Thanks it seems to be working great. I am unable to test the API feeds from my house, but should there be any issue in getting the tracker to recognize changes from feeds? When I input numbers it works perfectly. Have a great night. John

arkusM · Mar 30, 2010

memoney77 said:
Mark, Thanks it seems to be working great. I am unable to test the API feeds from my house, but should there be any issue in getting the tracker to recognize changes from feeds? When I input numbers it works perfectly. Have a great night. John

It should work.
However the macro is a bit more complex than what you asked for. If your API calls change frequently then you might have some performance issues.
You may want to trim back the code to just do what you require, like take out the formula tracking.
I also notice that I don't have application.screenupdating =false in the code you may want to add.

Track Changes via Macro

ManSim

New Member

Excel Facts

arkusM

Well-known Member

memoney77

New Member

arkusM

Well-known Member

memoney77

New Member

arkusM

Well-known Member

memoney77

New Member

arkusM

Well-known Member

memoney77

New Member

arkusM

Well-known Member

Similar threads

Forum statistics

Share this page

Track Changes via Macro

New Member

Excel Facts

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock