Excel-Access ADO Update Values ​​

Question

Estoy tratando de actualizar una tabla en Access desde los valores en excel, sin embargo, cada vez que ejecuto el código crea nuevas filas en lugar de actualizar las existentes, ¿por qué? Soy nuevo en ADO, por lo que cualquier recomendación es muy apreciada

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 

Answer 1

Aquí hay algunas notas.

Un ejemplo de actualización de fila por fila

''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 

Una opción más fácil: actualización de todas las filas

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 

Answer 2

Su llamada a .AddNew está creando nuevas filas.

Answer 3

Fionnuala

Muchas Gracias por t él 'Opción más fácil' para actualizar todas las filas.

Sólo para compartir que en mi caso (Office 2007 con archivo de Excel en formato .xlsm) que tenía que cambiar las cadenas de conexión con el fin de reproducir el ejemplo:

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 " _

A continuación se muestra un ejemplo de una consulta de actualización inversa: actualizar una tabla en Excel a partir de los valores de Acceso. (probado con Office 2007 y ADO 2.8, Excel archivo en formato .xlsm y acceso a archivos en formato .mdb)

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 

A continuación se muestra el mismo ejemplo, pero utilizando un objeto de conjunto de registros:

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