MS Excel Audit Trail / Log Debug Issue when formatting cells or using the date picker

Hi, Please help.

I've been working on this audit trail / log for MS Excel. I downloaded the spreadsheet from the following link: http://excelexperts.com/VBA-Tips-Log-An-Audit-Trail

Whenever, I do any format or anything unrelated to simply typing in data in a cell in Sheet 1, I get a debug error.

Is there a way to add code to the current code to ignore formatting and use of other code such as the date picker to avoid the debug issue?

I've attached my working spreadsheet. The Desc tab also contains a description of this issue, which is Issue 2 -- the focus of this thread. I will post the remaining issues 3-11 separately.

Thank you in advance for your assistance!
Test-Report-v2.xlsm
ckwillGWUAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Zack BarresseCEOCommented:
Hello,

Not sure what debug error you're getting.  I would change the code slightly as it is not very efficient nor robust.  I would suggest using something similar to this, although there isn't any *strong* error handling with it...

Option Explicit

Dim PreviousValue As Variant
Dim rCellWs As Range
Dim rLastCellWs As Range
Dim iRowWs As Long

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim wsLog As Worksheet
    Set wsLog = ThisWorkbook.Sheets("log")
    Set rLastCellWs = wsLog.Cells.Find(What:="*", After:=wsLog.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    iRowWs = rLastCellWs.Row + 1
    For Each rCellWs In Target.Cells
        If rCellWs.Value <> PreviousValue Then
            '/// Assumes column A is date/time
            wsLog.Cells(iRowWs, "A").Value = VBA.Now()
            '/// Assumes Office name in column B
            wsLog.Cells(iRowWs, "B").Value = Application.UserName
            '/// Assumes computer login name in column C
            wsLog.Cells(iRowWs, "C").Value = Environ("USERNAME")
            '/// Assumes affected target cell address in column D
            wsLog.Cells(iRowWs, "D").Value = rCellWs.Address(0, 0)
            '/// Assumes previous value in column E
            wsLog.Cells(iRowWs, "E").Value = PreviousValue
            '/// Assumes new value in column F
            wsLog.Cells(iRowWs, "F").Value = rCellWs.Value
            '/// Increments row number
            iRowWs = iRowWs + 1
            '/// Checks for no more room
            If iRowWs >= Me.Rows.Count Then
                'no more room
                'create new worksheet log?  I would... and set a new worksheet log variable to keep with the iterations
            End If
        End If
    Next rCellWs
End Sub

Open in new window


You can't actually log any formatting changes taken place, as it won't set off a change event.  Values changing, yes, formats, no.

I'm guessing your issue number 3 is from your use of ActiveCell where you're using that to put the picker value, but I'm not sure.  It's not recommended to use ActiveCell though, unless you actually need that for a specific reason.  Can you explain how/why you're using that control?

I have to run at the moment but will look at your other issues later.

Regards,
Zack Barresse
0
ckwillGWUAuthor Commented:
Zack,

I'm not exactly sure why the ActiveCell is there for the date picker, as I downloaded this example from the link listing in the descript. However, the sheet1 code was updated as follows --

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
   
    If Not Intersect(Target, [G:G]) Is Nothing Or Not Intersect(Target, [H:H]) Is Nothing Then
        Cancel = True
        UserForm1.Show
    End If
End Sub

I'm not having the issue any longer with the date picker. Also, my other issues have been resolved.

I have to update with your suggestions and see if that will solve my last issue in getting the date and time stamp with this running log.

Thanks for your input and taking a look into this...
0
ckwillGWUAuthor Commented:
So far looks good, but when I added to my sheet, I noticed the usernane is duplicated (in column b and in column c). Also, is there a way to keep track of what was changed or updated (in additon to the additions) as was previously done in the other code (e.g., jordan changed cell $H$3 from 1/29/1900 to 5/18/2012)?
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

Zack BarresseCEOCommented:
I noticed the usernane is duplicated (in column b and in column c)
So mots times this will be the case.  You may get times when someone puts a different name when they register Office, or people who change the names, or those who put company names.  They give you two very different pieces of information, but often times they are the same.  I would recommend having both.  When they are not equal, you will be able to spot it fairly easily (or run a script on it, or filter, etc) and you'll be the wiser for it, whereas if you don't, you won't be the wiser.

Also, is there a way to keep track of what was changed or updated (in additon to the additions) as was previously done in the other code (e.g., jordan changed cell $H$3 from 1/29/1900 to 5/18/2012)?
So instead of putting the information into one cell, my code breaks it out into multiple columns.  I would recommend this way.  For the reason above as well as normalization.  It will be easier to create reports and find information this way.  You will be able to filter on it and Pivot the data fairly easily.  If you really want to keep it in one cell, you can do so, but I would recommend against doing so.  The way I posted will be easier and better for getting data out of.  We can do either way for you though, so just let us know.

Regards,
Zack Barresse
0
ckwillGWUAuthor Commented:
I agree with you on the users' name -- that makes perfect sense.

On the tracking changes in separate cells, I received blank cells for that part. I attached a version of the spreadsheet where I updated with your code.

I could have missed something as well.
Test-Report-v2---Copy.xlsm
0
dlmilleCommented:
Here's my current iteration ---
I discovered if you insert rows/columns you could get an error.  I modified Zach's code to align with your log sheet, and incorporate all prior changes from previous questions, so you can fully test, including the datepicker dropdown right on top of the cell.

Also previousValue is a variant, and there needs to be error checking around that and if you're going to use Zach's code which I believe a good value add, then we need to first check if  previousValue is an array (re: multiple cell changes are being made so need to parse the previousValue as an array on each cell being logged.

I also repaired your log sheet Date/Time logging which logs the date/time of any changes made in the log sheet, by moving the log sheet down to start at row 4, otherwise it would not log that properly or prompt an error as well.

See Worksheet_Change() code in the Log sheet.


Here's the revised code log:

In log sheet:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim bLogChange As Boolean

'may not need this as format of log sheet has changed, thus range A1 and A2 are out of context?  However forcing log sheet to start lower so this can be logged
    
    For Each r In Target
        If Not Intersect(r, Range("$A$3:$A$2090")) Is Nothing And r.Value <> vbNullString Then
            bLogChange = True
            Exit For
        End If
    Next r
    
    If bLogChange Then

        Range("A1") = Date
        Range("A2") = Time

    End If

End Sub

Open in new window


In Module 1 - handles date picker on Sheet1:
Sub datePickerManager(Target As Range, bDisplay As Boolean)
Dim dpkrTemp As OLEObject
Dim WS As Worksheet
Dim vType As Variant
Dim chkDVList As Variant
Dim proceedSetup As Boolean

    Set WS = ActiveSheet

    On Error Resume Next    'connect to temporary Date Picker "TempCombo", testing along the way using Err.Number

    Set dpkrTemp = ActiveSheet.OLEObjects("TempDpkr")
    If Err.Number <> 0 Then    'the Date Picker object must have been inadvertently deleted, so let's create it
        Set dpkrTemp = ActiveSheet.OLEObjects.Add(ClassType:="MSComCtl2.DTPicker.2")
        dpkrTemp.Name = "TempDpkr"
    End If

    On Error GoTo errHandler
    If bDisplay Then
        With dpkrTemp
            .Left = Target.Left
            .Top = Target.Top
            .Visible = True
            .Width = Target.Width + 5
            .Height = Target.Height + 5
            .LinkedCell = Target.Address
            .Activate
        End With
    Else
        With dpkrTemp
            'hide the Date Picker, and get it out of the way from inadvertent deletion
            If .Visible = True Then
                .Visible = False
                .Left = Range("BB5000").Left
                .Top = Range("BB5000").Top
            End If
        End With
    End If

errHandler:
    'do Nothing for the moment
End Sub

Open in new window

In Sheet1 code page - calls all the right routines based on events:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long

    If Not IsError(PreviousValue) And Not IsEmpty(PreviousValue) Then
        Call logResults(Target)
    End If
    
    If Target.Count > 1 Then Exit Sub    'not handling at the moment - this is if more than one cell is changed simultaneously

    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        If Target.Value = "On Hold" And Left(Range("I" & Target.Row).Formula, 1) <> "=" Then    'prompt user
            MsgBox "Please Enter comments for On HOLD status"
        End If
    End If
    
    lastRow = Range("A:I").Find(what:="*", LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    If Target.Worksheet.Cells(lastRow, "H").Value = vbNullString Then
        Application.EnableEvents = False
        Target.Worksheet.Cells(lastRow, "H").Formula = "=IF(UPPER(LEFT(F" & Target.Row & ",6)) = ""STATUS"",IFERROR(VLOOKUP(F" & Target.Row & ",StatusDaysAdvanced,3,0),0)+G4,"""")"
        Application.EnableEvents = True
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    PreviousValue = Target

    Call datePickerManager(Target, False)

End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

    If Target.Count > 1 Then Exit Sub

    If Not Intersect(Target, [G:G]) Is Nothing Or Not Intersect(Target, [H:H]) Is Nothing Then
        Cancel = True
        Call datePickerManager(Target, True)
    End If

End Sub

Open in new window


In Module 4 - the code Zack started to log results:
Option Explicit
Public PreviousValue As Variant
Sub logResults(Target As Range)
Dim rCellWs As Range
Dim rLastCellWs As Range
Dim iRowWs As Long
Dim wsLog As Worksheet
Dim checkValue As Variant
Dim lIdx As Long

    Set wsLog = ThisWorkbook.Sheets("log")
    Set rLastCellWs = wsLog.Cells.Find(what:="*", After:=wsLog.Cells(1, 1), lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlPrevious)
    iRowWs = rLastCellWs.Row + 1
    
    For Each rCellWs In Target
        lIdx = 1
        
        If VarType(PreviousValue) = 8204 Then '8204 - variant array
            On Error Resume Next
            checkValue = Application.Transpose(PreviousValue)(lIdx)
            If Err.Number <> 0 Then 'perhaps a row move instead of column move
                Err.Clear
                checkValue = Application.Transpose(Application.Transpose(PreviousValue))(lIdx)
                If Err.Number <> 0 Then 'capitulate with unknown
                    checkValue = "unknown"
                End If
            End If
            On Error GoTo 0
        End If
        If IsError(PreviousValue) Or IsEmpty(PreviousValue) Then
            checkValue = "unknown"
        End If
        If rCellWs.Value <> checkValue Then
            'log description column A with Office Username & Windows Login Name
            wsLog.Cells(iRowWs, "A").Value = Application.UserName & " - " & Environ("USERNAME") & " changed cell " & Target.Address _
                                             & " from ->" & checkValue & "<- to ->" & rCellWs.Value & "<-"

            'log Date in Column B
            wsLog.Cells(iRowWs, "B").Value = Format(Now(), "MM/DD/YYYY")

            'log Time in Column C
            wsLog.Cells(iRowWs, "C").Value = Format(Now(), "HH:MM AM/PM")

            'log Audit Log in Column D
            wsLog.Cells(iRowWs, "D").Formula = "=""[""&RC[-3] & ""] ["" & text(RC[-2],""MM/DD/YYYY"") & ""] ["" & text(RC[-1],""HH:MM AM/PM"")" & "&""]"""
            wsLog.Cells(iRowWs, "D").Value = wsLog.Cells(iRowWs, "D").Value

            '/// Increments row number
            iRowWs = iRowWs + 1
            '/// Checks for no more room
            If iRowWs >= Target.Worksheet.Rows.Count Then
                'no more room
                'create new worksheet log?  I would... and set a new worksheet log variable to keep with the iterations
            End If
        End If
    Next rCellWs

End Sub

Open in new window


See attached.

The only modification I can see perhaps is getting that formula in for Due date, when a new row is being added.  I added that as well.


Enjoy!

Dave
Test-Report-v7.xlsm
0
dlmilleCommented:
Minor modification - on adding new row to Sheet1, also check column I and if blank, put the On Hold warning statement there:

in Sheet1 codepage:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long

    Call logResults(Target)
    
    If Target.Count > 1 Then Exit Sub    'not handling at the moment - this is if more than one cell is changed simultaneously

    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        If Target.Value = "On Hold" And Left(Range("I" & Target.Row).Formula, 1) <> "=" Then    'prompt user
            MsgBox "Please Enter comments for On HOLD status"
        End If
    End If
    
    lastRow = Range("A:I").Find(what:="*", LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    If Target.Row = lastRow Then 'A change was made on another row than the last row, so skip
        If Target.Worksheet.Cells(lastRow, "H").Value = vbNullString Or Target.Worksheet.Cells(lastRow, "I").Value = vbNullString Then
            Application.EnableEvents = False
            If Target.Worksheet.Cells(lastRow, "H").Value = vbNullString Then
                Target.Worksheet.Cells(lastRow, "H").Formula = "=IF(UPPER(LEFT(F" & Target.Row & ",6)) = ""STATUS"",IFERROR(VLOOKUP(F" & Target.Row & ",StatusDaysAdvanced,3,0),0)+G4,"""")"
            End If
            If Target.Worksheet.Cells(lastRow, "I").Value = vbNullString Then
                Target.Worksheet.Cells(lastRow, "I").Formula = "=IF(F" & Target.Row & "=""On HOLD"",""Enter comments for On HOLD status"","""")"
            End If
            Application.EnableEvents = True
        End If
    End If
End Sub

Open in new window


I put the error checking on the logResults call, as opposed to doing it before the call as a bit more is going on with that.

See attached.

Dave
Test-Report-v9.xlsm
0
dlmilleCommented:
I guess I did more than what you wanted, re: 200 points, etc., but felt compelled to pull all this together as I assisted on build up questions to this.  Zack - sorry to hijack the thread, lol.

This is not the first request to audit sheet changes so I was intrigued.  Nice bit of logic you found in that original tip and now I can point to the code we've helped you build up to this, based on all this stuff in the knowledgebase.

Dave
0
dlmilleCommented:
Apologies for all the posts.  Here's my last...


upon further read, I've reverted the log sheet to add the fields you and Zack were working to allow data filters/pivot table action to see all changes against a certain cell or by a certain user.

Option Explicit
Public PreviousValue As Variant
Sub logResults(Target As Range)
Dim rCellWs As Range
Dim rLastCellWs As Range
Dim iRowWs As Long
Dim wsLog As Worksheet
Dim checkValue As Variant
Dim lIdx As Long
Dim mIdx As Long
Dim vCombine As Variant
Dim strOut As String

    Set wsLog = ThisWorkbook.Sheets("log")
    Set rLastCellWs = wsLog.Cells.Find(what:="*", After:=wsLog.Cells(1, 1), lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlPrevious)
    iRowWs = rLastCellWs.Row + 1
    
    For Each rCellWs In Target
        lIdx = 1
        
        If VarType(PreviousValue) = 8204 Then '8204 - variant array
            On Error Resume Next
            checkValue = Application.Transpose(PreviousValue)(lIdx)
            If Err.Number <> 0 Then 'perhaps a row move instead of column move
                Err.Clear
                checkValue = Application.Transpose(Application.Transpose(PreviousValue))(lIdx)
                If Err.Number <> 0 Then 'capitulate with unknown
                    checkValue = "unknown"
                End If
            End If
            On Error GoTo 0
        End If
        If IsError(PreviousValue) Or IsEmpty(PreviousValue) Then
            checkValue = "unknown"
        End If
        If rCellWs.Value <> checkValue Then
            'log description column A with Office Username & Windows Login Name
            wsLog.Cells(iRowWs, "A").Value = Application.UserName & " - " & Environ("USERNAME") & " changed cell " & Target.Address _
                                             & " from ->" & checkValue & "<- to ->" & rCellWs.Value & "<-"

            'log User in Column B
            wsLog.Cells(iRowWs, "B").Value = Application.UserName
            
            'log Windows Login in Column C
            wsLog.Cells(iRowWs, "C").Value = Environ("USERNAME")
            
            'log Date in Column D
            wsLog.Cells(iRowWs, "D").Value = Format(Now(), "MM/DD/YYYY")
            
            'log Time in Column E
            wsLog.Cells(iRowWs, "E").Value = Format(Now(), "HH:MM AM/PM")
            
            'log Cell changed in Column F
            wsLog.Cells(iRowWs, "F").Value = Target.Address
            
            'log From in Column G
            wsLog.Cells(iRowWs, "G").Value = checkValue
            
            'log To in Column H
            wsLog.Cells(iRowWs, "H").Value = rCellWs.Value
            
            'Combine it all in column I - is this needed anymore? If so, uncomment this thread
            'vCombine = Application.Transpose(Application.Transpose(wsLog.Range(wsLog.Cells(iRowWs, "A"), wsLog.Cells(iRowWs, "I"))))
            'strOut = "[" & vCombine(LBound(vCombine))
            'For mIdx = LBound(vCombine) + 1 To UBound(vCombine)
            '    strOut = strOut & "][" & vCombine(mIdx)
            'Next mIdx
            'wsLog.Cells(iRowWs, "I").Value = strOut & "]"
            
            '/// Increments row number
            iRowWs = iRowWs + 1
            '/// Checks for no more room
            If iRowWs >= Target.Worksheet.Rows.Count Then
                'no more room
                'create new worksheet log?  I would... and set a new worksheet log variable to keep with the iterations
            End If
        End If
    Next rCellWs

End Sub

Open in new window


See attached.

Dave
Test-Report-v10.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
ckwillGWUAuthor Commented:
Ok. Thanks both Zack and Dave. I'm going to go through and combine aspects of all the workbooks into one file. Once completed, I'll post for review of any minor kinks or tweeks needed. Today, I plan on closing my current two posts open and adding two knew ones - for this same workbook. The first will be related to providing a link back to the original Sheet1 record from the Report created .. And, then a the last one will be for any minor issues with everything working seemlessly together. I may not get to this until Monday... Enjoy your weekend! Thanks again for your help.
0
Zack BarresseCEOCommented:
Very nice, Dave.  :)

Have a great weekend all!

Regards,
Zack
0
ckwillGWUAuthor Commented:
Great teamwork. Almost there. Thanks Zack and Dave for your patience.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.