Excel-Access ADO Update Values

I am trying to update a table in Access from the va开发者_如何转开发lues in excel, however every time i run the code it creates new rows instead of updating the already existing ones, any ideas why? I am new to ADO, so any advised is well appreciated

Private Sub SelectMaster()

Dim db As New ADODB.Connection
Dim connectionstring As String
Dim rs1 As Recordset
Dim ws As Worksheet

Set ws = ActiveSheet

connectionstring = "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=C:\Users\Giannis\Desktop\Test.mdb;"

db.Open connectionstring

Set rs1 = New ADODB.Recordset
rs1.Open "Men", db, adOpenKeyset, adLockOptimistic, adCmdTable


r = 6
Do While Len(Range("L" & r).Formula) > 0
With rs1
.AddNew

.Fields("Eva").Value = ws.Range("L" & r).Value
.Update

End With
r = r + 1
Loop

rs1.Close

'close database
db.Close

'Clean up
Set rs1 = Nothing
Set rs2 = Nothing
Set db = Nothing
End Sub

Here are some notes.

An example of updating row by row

''Either add a reference to:
''Microsoft ActiveX Data Objects x.x Library
''and use:
''Dim rs As New ADODB.Recordset
''Dim cn As New ADODB.Connection
''(this will also allow you to use intellisense)
''or use late binding, where you do not need
''to add a reference:
Dim rs As Object
Dim cn As Object

Dim sSQL As String
Dim scn As String
Dim c As Object

scn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\docs\dbto.mdb"

''If you have added a reference and used New
''as shown above, you do not need these
''two lines
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open scn

sSQL = "SELECT ID, SName, Results FROM [Test]"

''Different cursors support different
''operations, with late binding
''you must use the value, with a reference
''you can use built-in constants,
''in this case, adOpenDynamic, adLockOptimistic
''see: http://www.w3schools.com/ADO/met_rs_open.asp

rs.Open sSQL, cn, 2, 3

For Each c In Range("A1:A4")
    If Not IsEmpty(c) And IsNumeric(c.Value) Then
        ''Check for numeric, a text value would
        ''cause an error with this syntax.
        ''For text, use: "ID='" & Replace(c.Value,"'","''") & "'"

        rs.MoveFirst
        rs.Find "ID=" & c.Value

        If Not rs.EOF Then
            ''Found
            rs!Results = c.Offset(0, 2).Value
            rs.Update
        End If
    End If
Next

An easier option: update all rows

scn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\docs\dbto.mdb"

Set cn = CreateObject("ADODB.Connection")

cn.Open scn

sSQL = "UPDATE [Test] a " _
  & "INNER JOIN " _
  & "[Excel 8.0;HDR=YES;IMEX=2;DATABASE=C:\Docs\WB.xls].[Sheet1$] b  " _
  & "ON a.ID=b.ID " _
  & "SET a.Results=b.Results"

cn.Execute sSQL, RecsAffected
Debug.Print RecsAffected

Your call to .AddNew is creating new rows.

Fionnuala

Many Thanks for the 'Easier Option' to update all rows.

Just to share that in my case (Office 2007 with Excel file in .xlsm format) I had to change the connection strings in order to reproduce the example:

scn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\docs\dbto.mdb"
...
& "[Excel 12.0 Xml;HDR=YES;IMEX=2;DATABASE=C:\Docs\WB.xls].[Sheet1$] b " _

EDIT: an example updating access row by row (using arrays)

On Error GoTo ExceptionHandling
With Application
    '.EnableEvents = False
    .ScreenUpdating = False
End With

Dim cnStr As String, sSQL As String, ArId As Variant, ArPrice As Variant, i As Integer, ws As Worksheet, LastRow as Long
Set ws = Sheets("Sheet1")
cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.Path & "\Test.mdb;Jet OLEDB:Database Password=123"

Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.CursorLocation = adUseServer
cn.Open cnStr

Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = cn

With ws
    LastRow = .Cells(1000, 1).End(xlUp).Row
    ArId = Application.Transpose(.Range(.Cells(17, 1), .Cells(LastRow, 1)))
    ArPrice = Application.Transpose(.Range(.Cells(17, 3), .Cells(LastRow, 3)))

    For i = 1 To UBound(ArId)
        If ArPrice(i) = "" Then GoTo ContinueLoop
            sSQL = "UPDATE PRICES SET Price = " & Replace(ArPrice(i), ",", ".") & " WHERE Id =" & ArId(i)
            cmd.CommandText = sSQL
            'For statements that don't return records, execute the command specifying that it should not return any records
            'this reduces the internal work, so makes it faster
            cmd.Execute , , adCmdText + adExecuteNoRecords
            'another option using the connection object
            'cn.Execute sSQL, RecsAffected
            'Debug.Print RecsAffected
ContinueLoop:
    Next i
End With

CleanUp:
    On Error Resume Next
    With Application
        '.EnableEvents = True
        .ScreenUpdating = True
    End With
    On Error Resume Next
    Set cmd = Nothing
    cn.Close
    Set cn = Nothing
    Exit Sub
ExceptionHandling:
    MsgBox "Error: " & Err.Description & vbLf & Err.Number
    Resume CleanUp

Below is an example of a reverse update query: updating a table in Excel from the values in Access. (tested with Office 2007 and ADO 2.8, excel file in .xlsm format and access file in .mdb format)

Sub Update_Excel_from_Access()

Dim cn As ADODB.Connection
Set cn = New ADODB.Connection

'different options, tested OK
'cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;"";"
'cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName & ";Extended Properties=Excel 12.0 Xml;"
cn.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & ActiveWorkbook.FullName & ";ReadOnly=0;"

Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = cn

cmd.CommandText = "UPDATE [Sheet1$] a " _
  & "INNER JOIN " _
  & "[;Database=" & ThisWorkbook.Path & "\data.mdb].[Test] b  " _
  & "ON a.ID=b.ID " _
  & "SET a.Results=b.Results"
cmd.Execute , , adCmdText

'Another option, tested OK
'sSQL = "UPDATE [Sheet1$] a " _
'  & "INNER JOIN " _
'  & "[;Database=" & ThisWorkbook.Path & "\data.mdb].[Test] b  " _
'  & "ON a.ID=b.ID " _
'  & "SET a.Results=b.Results"
'cn.Execute sSQL, RecsAffected
'Debug.Print RecsAffected

Set cmd = Nothing
cn.Close
Set cn = Nothing
End Sub

Below is the same example but using a recordset object:

Sub Update_Excel_from_Access_with_Recordset()
Dim sSQL As String
On Error GoTo ExceptionHandling

Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.CursorLocation = adUseServer

'different options, tested OK
'cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;"";"
'cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName & ";Extended Properties=Excel 12.0 Xml;"
cn.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & ActiveWorkbook.FullName & ";ReadOnly=0;"

'Create a recordset object
Dim rst As ADODB.Recordset
Set rst = New ADODB.Recordset

sSQL = "SELECT a1.Results As er, a2.Results As ar " _
  & "FROM [Sheet1$] a1 INNER JOIN [;Database=" & ThisWorkbook.Path & "\data.mdb].[Test] a2 " _
  & " ON a1.[ID] = a2.[ID]"

With rst
  .CursorLocation = adUseServer
  .CursorType = adOpenKeyset
  .LockType = adLockOptimistic
  .Open sSQL, cn
  If Not rst.EOF Then
    Do Until rst.EOF
      rst!er = rst!ar
      .Update
      .MoveNext
    Loop
    .Close
  Else
    .Close
  End If
End With

CleanUp:
 Cancelled = False
 On Error Resume Next
 cn.Close
 Set rst = Nothing
 Set cn = Nothing
 Exit Sub
ExceptionHandling:
  MsgBox "Error: " & Err.description
  Resume CleanUp
End Sub