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.
'xlErrorLog
'v1.03a 2013-08-09 12:26
'===========================================================================
' HELP CONTACT
'===========================================================================
' Code is provided without warranty and can be stolen and amended as required.
' Tom Parish
' TJP@tomparish.me.uk
' http://baldywrittencod.blogspot.com
' 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
'=====================================================================
' VERSION HISTORY
'=====================================================================
' 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
LogNew:
'==============================
' CREATE ERROR LOG IN MEMORY
'==============================
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
LogExists:
'==============================
' ADD TO ERROR LOG IN MEMORY
'==============================
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
Loop
AddError:
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
LogDump:
'=============================
' DUMP ERROR LOG ONTO SHEET
'=============================
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
Else
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))
'!ERROR!
'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"
Else
'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)
Else
'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
Loop
End If
DoneDump:
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
.Activate
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