Selectively Update or Create New Records in Access From Excel 2

[LevelThought]

I continue to receive a "automation error" (Run-time error - 2147217843 (80040e4d)) upon trying to selectively create new records or update existing records in an Access table from an Excel Worksheet using the following code:

Sub CompleteDataToAccessAug2()
Dim ADOC As New ADODB.Connection
Dim DBS As New ADODB.Recordset
ADOC.Open "Provider=Microsoft.Jet.oledb.4.0;" & _
"Data Source=C:\Access Databases\TestReport.mdb;"
DBS.Open "tblVariance", ADOC, adOpenKeyset, adLockOptimistic, adCmdTable
Sheets("Data").Activate
Range("A2").Select
On Error GoTo CompleteDataToAccess_err
Do Until ActiveCell.Value = ""
With DBS
strSQL = "select * from tblVariance where AcctNo=" & ActiveCell.Range("Acct") & ""

On Error Resume Next
.Open strSQL, cn, adOpenKeyset, adLockOptimistic, adCmdText
On Error GoTo 0
If .State = adStateOpen Then ' successfully opened the recordset
If .EOF Then ' no records returned
DBS.AddNew ' create a new record
DBS!ContractOrig = ActiveCell.Value
DBS!ReviewOrig = ActiveCell.Offset(0, 1).Value
DBS!AcctNo = ActiveCell.Offset(0, 2).Value
DBS.Update ' stores the new record
ActiveCell.Offset(1, 0).Select

Else
DBS!ReviewCurrent = ActiveCell.Offset(0, 3).Value
DBS!ExpPymtCurrent = ActiveCell.Offset(0, 4).Value
DBS!DateUpdated = Now()
DBS.Update ' stores the new record
ActiveCell.Offset(1, 0).Select
End If
End If
End With
Loop
CompleteDataToAccess_exit:
DBS.Close
ADOC.Close
Set ADOC = Nothing
Set DBS = Nothing
Exit Sub
CompleteDataToAccess_err:
MsgBox "Sorry - an error occurred..." & vbCrLf & "Number: " & Err.Number & _
vbCrLf & "Description: " & Err.Description
Resume CompleteDataToAccess_exit
End Sub

Any insight as to a resolution.

Basically, using this approach to the updating of calculated fields within my Access table on a daily basis.

Thanks in advance.

 

[JerryKlmns]

My post of 4 Aug 05 5:14 says
I hope you get one and only one record. If you get more than one, you should loop all filtered records and update them.

So this loop shall do it

While Not DBS.EOF
   DBS.Fields("AccNo") = ActiveCell.Offset(0, 2).Value
   DBS.Fields("Balance") = ActiveCell.Offset(0, 3).Value
   DBS.Update 
   DBS.MoveNext
Wend