Is there a 'On Error Resume Next' function that also logs errors in VBA? - excel

Question

I have code which looks through an Excel table.
Sub ErrorCheck()
Dim ErrColl As New Collection
Dim NameColl As New Collection
Worksheets(WorksheetName).Select
Worksheets(WorksheetName).Range("B5").Select
Do Until IsEmpty(ActiveCell)
On Error Goto eh
NameColl.Add ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Loop
eh:
ErrColl.Add ActiveCell.Value
End Sub
The above will stop once a duplicate occurs. I don't want the code to stop when a duplicate occurs, because I need all the duplicates to be shown in msgbox/logged onto a file. 'Resume next' will give me the right answer with no duplicates, but will not show the where the duplicates are. 'GoTo' will only show the first error. Is there another way to do this?

Answer 1

You can always combine ´On Error Resume Next´ with a check of the Error code. The following (very silly) code should illustrate how this works:
On Error Resume Next
Dim i As Integer
Dim m As Integer
Dim n As Double
For i = 1 To 10
m = i Mod 3
n = i / m
If Err.Number > 0 Then
MsgBox ("Handle error here")
Err.Number = 0
Else
MsgBox ("n: " + Str(n))
End If
Next
What this is doing is to test for the Error code on the line after the error is likely to occur. If there was no error (Err.Number = 0), the code continues with the Else. If an error has been raised (in this case Err.Number = 11 - division by zero when i is 3, 6 and 9), then you can handle the error within the If and the code continues after the End If. Notice that you need to reset the Err.Number back to 0!

Answer 2

I wouldn't select stuff so much because it will slow your code down.
Anyway, here's something that might be of use. Change the code where necessary.
Sub ErrorCheck()
Dim rCell As Range
Dim lRow As Long
Dim rCheck
With Worksheets(1) 'change to suit
Set rCell = .Cells(5, 2)
Set rCheck = rCell
lRow = 1
Do Until rCell(lRow).Value = vbNullString
Set rCheck = Union(rCheck, rCell.Offset(lRow))
With rCell.Offset(lRow)
If WorksheetFunction.CountIf(rCheck, .Value) > 1 Then
Debug.Print .Address & vbTab & .Value 'using the Immediate Window as an example
End If
End With
lRow = lRow + 1
Loop
End With
Set rCell = Nothing
Set rCheck = Nothing
End Sub