Track Changes via Macro

[ManSim]

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-comfficeffice" /><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

 

[memoney77]

Mark, I came accross this thread. See what you think.
http://www.excelforum.com/excel-pro...in-cell-from-formula-to-auto-run-a-macro.html

 

[arkusM]

Ok John,

Give this a go.
I tested it on some feeds that we have, not on my computer that is why I asked if your feeds were public. And is seemed to work.

The code is triggered every 2 seconds, set in two places in the code.
Good luck.

Place this is a regular module

Option Explicit
Public dtime As Date
Sub SetVal()
Dim i As Integer, j As Integer, RngBottm As Integer, RngTop As Integer, RnginUse As Integer
Dim ArryCompare(), theRange As Range
With Sheet1
RngTop = 9 ' Starting Row
RngBottm = .Range("S65536").End(xlUp).Row
RnginUse = RngBottm - RngTop
Set theRange = .Range(.Cells(RngTop, 20), .Cells(RngBottm, 20))
ArryCompare = .Range(.Cells(RngTop, 19), .Cells(RngBottm, 19))
For i = 1 To RnginUse + 1
ArryCompare(i, 1) = .Cells(RngTop - 1 + i, 19)
Next i
theRange.Value = ArryCompare
End With
End Sub
Sub LoopthroughValues()
[COLOR=green]dtime = Now + TimeValue("00:00:02")[/COLOR]
Application.OnTime dtime, "LoopthroughValues"
Application.ScreenUpdating = False
Dim i As Integer, j As Integer, RngBottm As Integer, RngTop As Integer, RnginUse As Integer
Dim OldVal As Double, NewVal As Double, MultVal As Double
With Sheet1
RngTop = 9 ' Starting Row
RngBottm = .Range("S65536").End(xlUp).Row
RnginUse = RngBottm - RngTop
For i = 1 To RnginUse + 1
OldVal = Sheet1.Cells(RngTop - 1 + i, 19)
NewVal = Sheet1.Cells(RngTop - 1 + i, 20)
MultVal = Sheet1.Cells(RngTop - 1 + i, 21)
If NewVal <> OldVal Then
With Sheet2
'Set the values
With .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
.Value = Sheet1.Cells(RngTop - 1 + i, 20).Address
.Offset(0, 1).Value = NewVal
.Offset(0, 2).Value = OldVal
.Offset(0, 4) = (NewVal - OldVal) * MultVal
.Offset(0, 5) = Time
.Offset(0, 6) = Date
.Offset(0, 7) = Application.UserName
.Offset(0, 7).Borders(xlEdgeRight).LineStyle = xlContinuous
End With
End With
End If
Next i
Call SetVal 'Calls the macro to reset the "previous" values
End With
End Sub

Place this in the Wokbook code module (no need for my above code.)

Option Explicit
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
     Application.OnTime dtime, "LoopthroughValues", , False
End Sub
Private Sub Workbook_Open()
   Application.OnTime Now + TimeValue("00:00:02"), "LoopthroughValues"
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[memoney77]

mark, works great. I'm impressed. Thanks again for your help. One last question. If I simply want to pull the value of a cell and output it on sheet 2 how would I add that. For example if the quantity changes for Apple Stock I would like to just pull the label "Apple Stock" from column 2 on sheet1 and out put it with the previous code. The labels are all in the same row as the quantities. Have a great night. John

 

[arkusM]

Yeah I wondered of there would be any point in the address...
Either copy this or look at the RED row for the change

Sub LoopthroughValues()
dtime = Now + TimeValue("00:00:02")
Application.OnTime dtime, "LoopthroughValues"
Application.ScreenUpdating = False
Dim i As Integer, j As Integer, RngBottm As Integer, RngTop As Integer, RnginUse As Integer
Dim OldVal As Double, NewVal As Double, MultVal As Double
With Sheet1
RngTop = 9 ' Starting Row
RngBottm = .Range("S65536").End(xlUp).Row
RnginUse = RngBottm - RngTop
For i = 1 To RnginUse + 1
OldVal = Sheet1.Cells(RngTop - 1 + i, 19)
NewVal = Sheet1.Cells(RngTop - 1 + i, 20)
MultVal = Sheet1.Cells(RngTop - 1 + i, 21)
If NewVal <> OldVal Then
With Sheet2
'Set the values
With .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
[COLOR=red][B].Value = Sheet1.Cells(RngTop - 1 + i, 2) 'Changed from 20 to 2; to look at Column 2[/B][/COLOR]
.Offset(0, 1).Value = NewVal
.Offset(0, 2).Value = OldVal
.Offset(0, 4) = (NewVal - OldVal) * MultVal
.Offset(0, 5) = Time
.Offset(0, 6) = Date
.Offset(0, 7) = Application.UserName
.Offset(0, 7).Borders(xlEdgeRight).LineStyle = xlContinuous
End With
End With
End If
Next i
Call SetVal 'Calls the macro to reset the "previous" values
End With
End Sub

 

[memoney77]

Mark, Thanks a million, its working great. John

 

[ManSim]

Hi arkusM,
I wasn't around for various reasons hence my late THANK YOU for the code! I will try this at next occasion.

 

[bhushanvshah]

Hi..

I have a query

There are 100 Rows in the table
Column A & B, are through webquery, With Column B Changing every 30 seconds.
Column C is a manual entry value and will remain constant.
Column D is a IF formula

Macro Required is:
When There is change in cell is Column D, the entire row with Time to be recorded in Sheet2

For instance, if D5 gets the value "Target Achieved", Then entire D row to be recorded in sheet2
after some time if B5 gets the value " Target Achieved", Then entire B row to be recorded in Sheet 2

P.S.: The work of Sheet2, is like a log book. So all changes have to be recorded one by one. in Sheet2

Thanks
Bhushan

 

[arkusM]

Hi..

I have a query

There are 100 Rows in the table
Column A & B, are through webquery, With Column B Changing every 30 seconds.
Column C is a manual entry value and will remain constant.
Column D is a IF formula

Macro Required is:
When There is change in cell is Column D, the entire row with Time to be recorded in Sheet2

For instance, if D5 gets the value "Target Achieved", Then entire D row to be recorded in sheet2
after some time if B5 gets the value " Target Achieved", Then entire B row to be recorded in Sheet 2

P.S.: The work of Sheet2, is like a log book. So all changes have to be recorded one by one. in Sheet2

Thanks
Bhushan

Bhushan,

My apologies I do not have time to tweak this code for your requested purposes, but here is code that will generally do what you want and should get you going. It tracks changes to a sheet on a new tab and you should be able to customize as you need.


Cheers,
Mark

Put this in the ThisWorkbook code sheet

Option Explicit
Dim sOldAddress As String
Dim vOldValue As Variant
Dim sOldFormula As String
'---------------------------------------------------------------------------------------
' Procedure : Workbook_SheetChange
' Author    : mreierson
' Date      : 1/7/2009
' Purpose   : To track changes to any cell on a new tab
'               [url=http://www.mrexcel.com/forum/showthread.php?t=376400&referrerid=76744]VBA "ignoring" or exit sub with "Select All"[/url]
'               With many thanks to Colin_L for helping me get this to work
'---------------------------------------------------------------------------------------
'
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim wSheet As Worksheet
    Dim wActSheet As Worksheet
    Dim iCol As Integer
    Set wActSheet = ActiveSheet
    'Precursor Exits
    'If ActiveSheet.Name <> "Information" Then Exit Sub '***This Allows you to set which tab to monitor, if you want
    If vOldValue = "" Then Exit Sub
    '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 *****************************************************************************
        '******** 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"
    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
            sOldFormula = Cells(.Row(), 9)
            ' If .HasFormula Then
            '     sOldFormula = "'" & Target.Formula
            ' Else
            '     sOldFormula = vbNullString
            ' End If
        End If
    End With
End Sub

 

[bhushanvshah]

Thanks for your help. I willl try my best and do the needful.. cheers
Bhushan

 

[leroy79]

How would one modify the code so when pasting in a range of cells, rather than show "multiple cell Select", it shows the old/new value of each individual cell?

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.

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]VBA Express : Excel - Tracking Changes With Comments[/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