lange Datensätze aus Excel in Access übertragen

Option Explicit
'Verweis auf Microsoft ActiveX Data Objects 2.5 Library  !
Const pfad As String = "C:\Herber\Access"        'Access DB PFad
Const myAccessDB As String = "Datenbank.accdb"   'Access DB Dateiname
Const myDB As String = "ScanArchiv"              'DB-Tabellenname im Access
Const myTable As String = "Tabelle2"             'in diese Tabelle
Sub Station_Aktualisieren(myRow As Long)
On Error GoTo hell
Const APPNAME = "mod_Access / Station_Aktualisieren"
Dim crm As Long
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim ws As Worksheet
Set ws = Sheets(myTable)
Set con = New ADODB.Connection
con.Open ConnectionString:= _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & pfad & "\" & myAccessDB & ";" & _
"Mode=Share Exclusive"
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open Source:=myDB, _
ActiveConnection:=con, _
CursorType:=adOpenStatic, _
LockType:=adLockPessimistic, _
Options:=adCmdTableDirect
rs.Index = "PrimaryKey"
crm = ws.Cells(myRow, 1).Value
rs.Seek KeyValues:=crm, SeekOption:=adSeekFirstEQ
If rs.EOF Then
rs.AddNew
rs!crm = crm
End If
rs!Model = ws.Cells(myRow, 2)
rs!ProductRange = ws.Cells(myRow, 3)
rs!RepairArticle = ws.Cells(myRow, 4)
rs!ProductClass = ws.Cells(myRow, 5)
rs.Update
'*** Fehlerbehandlung
Err.Clear
hell:
If Err.Number = -2147467259 Then Resume     'Datenbank wird bereits verwendet
If Err.Number  0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description
rs.Close
Set rs = Nothing
con.Close
Set con = Nothing
End Sub

For i = 2 To 500
rs!Überschrift(i) = ws.Cells(myRow, i)
Next i