Monday 5 August 2013

VBA Modules: Excel: xlErrorLog v1.03a

Read this for full information on these modules

This nifty little Excel module stores errors in a log when running a long, complex macro, and then "dumps" them to an Excel worksheet when it's fnished.  There are a number of ways to do this, so this might not exactly fit your needs, and you may well already have a better solution, but this has worked for me a couple of times.

Note that "emsg" is a fairly blunt way of controlling the log macro, it's fully annotated though so it should make sense how it works.

'v1.03a 2013-08-09 12:26

' Code is provided without warranty and can be stolen and amended as required.
'   Tom Parish
'   DGF Help Contact: see BPMHelpContact module

' xlErrorLog
' errorlog("New")
'   Creates "Error Log" sheet in WB if not there already
'   --> Error Log sheet contains 2 columns:
'       Date & Time
'       Description
' errorlog("Description")
'   Records error with timestamp as elog([0=t|1=d], e)
' errorlog("Dump")
'   Dumps errors into log sheet when finished

' Additional modules required:
'   xlUtils v2.00

'   v1.03   module renamed; xlUtils bugfix; annotations improved
'   v1.02   rSort bugfix; annotations improved
'   v1.01   added option to replace duplicates
'   v1.00   created

Option Explicit

Public elog() As String

Sub errorlog(ByVal emsg As String _
    , Optional ByVal ReplaceDuplicates As Boolean = True)
'v1.03 2013-05-23 11:37
'"New" creates new errorlog
'"Dump" dumps errorlog
'"Any other message" is added to errorlog as new error
'ReplaceDuplicates = False will always add errors to list
'[ReplaceDuplicates = True] updates timestamps for existing errors
'--> Previous run record is left in place, i.e. fixed errors remain in
'    original position in the list when rerun.  If errors reoccur, the
'    timestamp is updated, and moved to below the latest heading.

Const emsgNew As String = "New"
Const emsgDump As String = "Dump"

If emsg = emsgNew Then GoTo LogNew
If emsg = emsgDump Then GoTo LogDump

Dim e As Long, etitle As String, bRD As Boolean, pp As String, tt As String
Dim rSort As Range

On Error GoTo LogNew  'errors when elog() not elog(n,n)
For e = 0 To 0
    etitle = elog(0, 0)
Next e
On Error GoTo 0
GoTo LogExists

On Error GoTo 0
If e < 1 Then  'error log not started
    ReDim elog(1, 0) As String
    elog(0, 0) = Now()
    elog(1, 0) = ""
    Exit Sub
End If

e = 0
On Error GoTo AddError
    Do Until elog(0, e) = ""   'elog(0, 0) is always date & time report is run
        If elog(1, e) = emsg Then
            Exit Sub   'stops duplicate errors, also stops repeating errors found in previous errorlogs
        End If
        e = e + 1       'increments to find next available e
On Error GoTo 0
ReDim Preserve elog(1, e) As String
etitle = elog(1, 0)
If Left(etitle, 15) = "NO ERRORS FOUND" Then
    etitle = Mid(etitle, 4, Len(etitle)) & ":"
End If
elog(1, 0) = etitle
elog(0, e) = Now()
elog(1, e) = emsg
Exit Sub

Dim wsE As Worksheet
Const wsEn As String = "Error Log"
With ThisWorkbook
If xlUtils.xlU_SheetExists(wsEn, ThisWorkbook) = True Then
    For Each wsE In .Worksheets
        If wsE.Name = wsEn Then Exit For
    Next wsE
    Set wsE = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    With wsE
        .Name = wsEn
        With .Range("A1:B2")
            .Interior.ColorIndex = 36
            .Font.Bold = True
        End With
        .Cells(1, 1) = "ERROR LOG"
        .Cells(2, 1) = "Date & Time"
        .Cells(2, 2) = "Error"
    End With
End If
End With

Dim f As Long, n As Long, d As Long

'count existing number of rows in error log
    f = Application.CountA(wsE.Columns(1))

'dump all errors to log ONLY if errors exist
'(0,0) is always Now()
'if 1st error exists, always at (0,1) and (1,1)
'if 2nd error exists, always at (0,2) and (1,2)
'!! runtime error 9 = trying to dump before elog(0,0) started
    If Left(elog(1, 0), 15) = "NO ERRORS FOUND" Then
        MsgBox elog(0, 0) & vbLf & "Completed: no errors found"
    'elog(1,0) = "ERRORS FOUND WHEN...."
On Error GoTo DoneDump
        Do Until elog(0, e) = ""
            d = 0  'd > 0 if duplicate error found
On Error Resume Next
            d = Application.Match(elog(1, e), wsE.Columns(2), 0)
On Error GoTo DoneDump
            If e > 0 And d > 0 And ReplaceDuplicates = True Then
            'duplicate error, just update timestamp (sorted later)
                wsE.Cells(d, 1).Value = elog(0, e)
            'new error, or new list of errors, add to end of list
                With wsE.Cells(1, 1).End(xlDown).Offset(1, 0)
                    With .Offset(n, 0)
                        .Value = elog(0, e)
                        If e = 0 Then .Bold = True Else .Bold = False  'only for first message
                    End With
                    With .Offset(n, 1)
                        .Value = elog(1, e)
                        If e = 0 Then .Bold = True Else .Bold = False  'only for first message
                    End With
                End With
                n = n + 1  'next new error
            End If
            e = e + 1  'next error
    End If
On Error GoTo 0
    tt = "errorlog"
    'If Not f = Application.CountA(wsE.Columns(1)) Then
    If n > 0 Then  'new errors exist
        If ReplaceDuplicates = True Then
        'existing replaced, must be new errors added
            pp = elog(0, 0) & vbLf & "New errors - check log"
            MsgBox pp, vbExclamation, tt
        Else    'all errors added to end of list
            pp = elog(0, 0) & vbLf & "Errors - check log"
            MsgBox pp, vbExclamation, tt
        End If
    Else    'no new errors, but may be some existing errors recurring
        pp = elog(0, 0) & vbLf & "Completed: no new errors found"
        MsgBox pp, vbInformation, tt
    End If
'sort by date & time to move updated errors to the end
    With wsE
        Set rSort = .Cells(2, 1)
        Set rSort = .Range(rSort.End(xlToRight), rSort.End(xlDown))
        rSort.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
    End With
'empty elog
ReDim elog(0 To 0) As String

End Sub

No comments:

Post a Comment