Excel hücreden Accese veri tabanına bilgi aktarmada sorun

[ikikan]

Nerde yanlış yapıyorum bir türlü beceremedim ?

Sub DbAc()
Dim adoCN As Object
Dim DatabasePath As String
'---------------Database açılcak--------------
On Error Resume Next
Set adoCN = CreateObject("ADODB.Connection")
DatabasePath = ActiveWorkbook.Path & "\RPDATA.mdb"
If Dir(DatabasePath) = "" Then
'MsgBox DatabasePath & " bulunamadı, programdan çıkılacak !", vbCritical, "TestMDB"
Exit Sub
End If
adoCN.Provider = "Microsoft.Jet.OLEDB.4.0"
adoCN.ConnectionString = DatabasePath
adoCN.Open
End Sub
Sub DbKapat()
'---------------Database kapanacak--------------
Dim adoCN As Object
On Error Resume Next
If adoCN.State = 1 Then
adoCN.Close
Else
End
End If
End Sub

Sub AccesseKaydet()
Call DbAc
Dim rs As Object
Dim nobul As Integer
Dim i As Integer
Set rs = CreateObject("ADODB.recordset")
With Sheets("VVV")
rs.Open "select from VG", adoCN, 1, 3
For i = 4 To .Range("O65536").End(3).Row
rs.AddNew
rs.Fields(0).Value = Cells(i, 1).Value
rs.Fields(1).Value = Cells(i, 2).Value
rs.Fields(2).Value = Cells(i, 3).Value
rs.Fields(3).Value = Cells(i, 4).Value
rs.Fields(4).Value = Cells(i, 5).Value
rs.Fields(5).Value = Cells(i, 6).Value
rs.Fields(6).Value = Cells(i, 7).Value
rs.Fields(7).Value = Cells(i, 8).Value
rs.Fields(8).Value = Cells(i, 9).Value
rs.Fields(9).Value = Cells(i, 10).Value
rs.Update
Next i
End With
MsgBox "Kayıtlar veritabanına aktarıldı", vbInformation
On Error Resume Next
Call DbKapat
End Sub