Excel track changes/checkbox clicks via VBA

[kmcroft13]

Hello,

I am using VBA to track changes in my worksheet in order to by-pass all of the known issues with Shared Workbooks and get similar functionality. I have pieced together code from various places to get a pretty good solution, but I am having problems tracking changes to checkbox values! My code tracks the old cell value, the new cell value, and the cell address, among other things which are working correctly. This workes great for regular worksheet values, but fails for checkbox clicks... I can get the new value to track properly, but not the old value.

All of the code below appears in the ThisWorkbook module:

Option Explicit
Dim sOldAddress As String
Dim vOldValue As Variant
Dim sOldFormula As String

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)     '''''''''''''''''''''''''''''''''''''''''''''
     'Thanks to lenze for getting me started on this project (http://vbaexpress.com/kb/getarticle.php?kb_id=909)
     '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("Workbook History")
     '**** Add the tracker Sheet if it does not exist ****
     
    If wSheet Is Nothing Then
        Set wActSheet = ActiveSheet
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Workbook History"
    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("Workbook History")
         '******** This bit of code moves the tracker over a column when the first columns are full**'
        If .Cells(4, 1) = "" Then '
            iCol = 1 '
        Else '
            iCol = .Cells(4, 256).End(xlToLeft).Column - 7 '
            If Not .Cells(65536, iCol) = "" Then '
                iCol = .Cells(4, 256).End(xlToLeft).Column + 1 '
            End If '
        End If '
         '********* END *****************************************************************************'
        .Unprotect Password:="Secret"
         
         '******** Sets the Column Headers **********************************************************
        If LenB(.Cells(4, iCol).Value) = 0 Then
            .Range(.Cells(4, iCol), .Cells(4, 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 = "'" & .Parent.Name & "'!" & .Address(external:=False)
         
        If .Count > 1 Then
                vOldValue = "Multiple Cell Select"
                sOldFormula = vbNullString
        Else
            If .Value = "" Then
                vOldValue = "NULL"
            Else
                vOldValue = .Value
            End If
                    
        If .HasFormula Then
            sOldFormula = "'" & Target.Formula
        Else
            sOldFormula = vbNullString
        End If
        
        End If
    End With
End Sub

Then I had this code in a macro attached to each checkbox... I suspect I need to add things to this macro to capture the old value, but how?

Dim addr As String
addr = ActiveSheet.CheckBoxes(Application.Caller).LinkedCell    
    With ActiveSheet.Range(addr)
        .Value = .Value
    End With


End Sub

Any ideas on how I can achieve this?

Thanks so much!