Übertrag EXCEL in ACCESS

Sub DatenInAccessDB()
Range("B22") = Now
Makro4
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
SearchEmploymentDate
Dim MsgText As String
On Error GoTo Err_Handler
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim SQL As String
sDataBaseFile = Worksheets("Setting").Cells(2, 3).Value
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set db = OpenDatabase(sDataBaseFile)
While Worksheets("DB_Transfer").Cells(3, 1).Value  ""
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set db = OpenDatabase(sDataBaseFile)
Set rs = db.OpenRecordset(SQL)
With rs
.AddNew
For i = 1 To Worksheets("Setting").Cells(2, 5).Value
.Fields(Worksheets("DB_Transfer").Cells(2, i).Value) = Worksheets("DB_Transfer") _
.Cells(3, i).Value
Next
.Fields("Frei20") = Worksheets("DB_Transfer").Cells(3, 25).Value
.Update
End With
Worksheets("DB_Transfer").Rows("3:3").Delete Shift:=xlUp
Worksheets("PERSONALPLANUNG").Cells(22, 2).Interior.Color = RGB(0, 255, 128)
rs.Close
db.Close
Wend
End_Handler:
Set rs = Nothing
Set db = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Call Calculate
Exit Sub
Err_Handler:
Worksheets("DB_Transfer").Cells(1, 1).Interior.Color = RGB(204, 0, 0)
msgNetzwerkfehler
Resume End_Handler
End Sub