Значения обновления ADO в Excel-Access

Question

Я пытаюсь обновить таблицу в Access из значений в Excel, однако каждый раз, когда я запускаю код, он создает новые строки вместо обновления уже существующих, есть идеи почему? Я новичок в ADO, так что любой советуется, высоко ценится

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

Вот несколько заметок.

Пример обновления строки за строкой

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

Более простой вариант: обновить все строки

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

Ваш вызов .AddNew создает новые строки.

Answer 3

Fionnuala

Большое спасибо за 'Более простой вариант' , чтобы обновить все строки.

Просто поделиться этим в моем случае (Office2007 с файлом Excel в формате .xlsm) Мне пришлось изменить строки подключения, чтобы воспроизвести пример:

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

РЕДАКТИРОВАТЬ: пример обновления строки доступа построчно (с использованием массивов)

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

Ниже приведен пример обратного запроса на обновление: обновление таблицы в Excel из значений в Access.(протестировано с Office 2007 и ADO 2.8, файл Excel в формате .xlsm и файл доступа в формате .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

Ниже приведен тот же пример, но с использованием объекта набора записей:

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