Solved

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

Posted on 2012-04-05
12
635 Views
Last Modified: 2012-08-28
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
0
Comment
Question by:ckwillGWU
  • 5
  • 4
  • 3
12 Comments
 
LVL 14

Expert Comment

by:Zack Barresse
ID: 37814803
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
 

Author Comment

by:ckwillGWU
ID: 37814865
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
 

Author Comment

by:ckwillGWU
ID: 37814876
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
 
LVL 14

Assisted Solution

by:Zack Barresse
Zack Barresse earned 100 total points
ID: 37814989
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
 

Author Comment

by:ckwillGWU
ID: 37815045
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
 
LVL 41

Expert Comment

by:dlmille
ID: 37815114
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
Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

 
LVL 41

Expert Comment

by:dlmille
ID: 37815125
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
 
LVL 41

Expert Comment

by:dlmille
ID: 37815145
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
 
LVL 41

Accepted Solution

by:
dlmille earned 100 total points
ID: 37815173
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
 

Author Comment

by:ckwillGWU
ID: 37816371
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
 
LVL 14

Expert Comment

by:Zack Barresse
ID: 37817024
Very nice, Dave.  :)

Have a great weekend all!

Regards,
Zack
0
 

Author Closing Comment

by:ckwillGWU
ID: 37857621
Great teamwork. Almost there. Thanks Zack and Dave for your patience.
0

Featured Post

Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

762 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

21 Experts available now in Live!

Get 1:1 Help Now