ADO Error Handling

I am using VBA in Excel to take the information in Excel, place it in an
array, and insert it into a database. The operation completes successfully,
however, I'd like to record any ADO errors that come up in the operation.
I'd like the error handling to operate similar to the 'Paste Errors' table in
Access.

The code is shown below. It first opens the database connection, then it
creates a worksheet to add any errors that come up during the add new
operation (errors if a record in another table does not exist or if
duplicates exist in the array). The code then adds the data in the array
into the table. If an error occurs, it should put the information into the
'Errors' worksheet, including the error description.

During execution, the data is correctly inserted into the database, however,
the 'Errors' tab ends up with twice as many records in it than it should.
The information as far as which records show up there are also off. The
code ends with an error stating that the subscript is out of range. It seems
as though it is not returning to the loop correctly, although I've never
tried to build error handling in before.

Any help is greatly appreciated.

' Open tblUser_Roles to add records
rs2.Open "tblUser_Roles", conn, adOpenKeyset, adLockOptimistic, adCmdTable

' Row Counter
Dim MaxRow
MaxRow = 1

' Worksheet Tab for Errors
ActiveWorkbook.Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "Errors"
Set q = ActiveWorkbook.Sheets("Errors")

' ADODB Error Handling
On Error GoTo myErr:

' Add Data to Database from the Array
For r = 1 To p_maxRole
rs2.AddNew
rs2("AUserID") = Data(r, 1)
rs2("RoleID") = Data(r, 2)
rs2("Priority") = Data(r, 3)
rs2.Update
Next r

'Error Handling Procedure
myErr:
If Err <> 0 Then
q.Cells(MaxRow, 1).Value = Data(r, 1)
q.Cells(MaxRow, 2).Value = Data(r, 2)
q.Cells(MaxRow, 3).Value = Data(r, 3)
q.Cells(MaxRow, 4).Value = r
q.Cells(MaxRow, 5).Value = Err.Description
MaxRow = MaxRow + 1
Resume Next
End If