从Excel VBA更新Access 2010表仅更新一条记录

Question

有足够的时间尝试从excel更新访问表。 我正在使用ADOB连接并循环浏览具有更新的电子表格。 可以是200条记录到1000条以上的记录。

运行以下代码时，尽管显示它已从我的测试数据中更新了1047条记录，但它只会更新访问表中的一条记录。

我正在更新具有62列的销售记录。 列“ BI”是引用后生成的唯一ID。 更新所指定的是基于“ BI”列（sQID）中的ID将QorB列中的数据从Q更改为B。

模块运行后，它表明已从中更新了1047条记录，但是当打开访问数据库时，它仅显示一条记录已更改。

谁能看到以下代码的任何严重错误？ 有没有更好的方法来更新来自Excel的大量数据的访问权限？

Sub updatedbtest2()

Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim rng As Range
Dim lngRow As Long
Dim lngID, LR, Upd
Dim sSQL As String

'Get Last Row of range used 
LR = Range("BI" & Rows.Count).End(xlUp).Row

Upd = LR - 1   
lngRow = 2    
Do While lngRow <= LR
lngID = Cells(lngRow, 61).Value   

    Set cn = New ADODB.Connection
    cn.Open "Provider = Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=C:\Database\sales.accdb;"

sQID = Cells(2, 61).Value

    Set rs = New ADODB.Recordset

       sSQL = "SELECT * FROM P&R WHERE QuoteID ='" & sQID & "';"  

rs.Open Source:=sSQL, ActiveConnection:=cn, LockType:=adLockOptimistic

        ' update fields within table with values from spreadsheet.
        With rs
            .Fields("QorB") = Cells(lngRow, 60).Value
            .Fields("BDate") = Cells(lngRow, 62).Value
            .update
        End With        
    rs.update   
   'Next rng

lngRow = lngRow + 1

    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing       


Loop

MsgBox "You just updated " & Upd & " records"
End Sub

感谢您对此的关注。

我从建议中对代码进行了以下更改，结果完全相同。

访问记录显示片段

Sub updatedbtest2()

Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim rng As Range
Dim lngRow As Long
Dim sQID, LR
Dim sSQL As String

LR = Range("A" & Rows.Count).End(xlUp).Row
Debug.Print LR


Upd = LR - 1
lngRow = 2
sQID = Cells(lngRow, 61).Value

'Do While lngRow <= LR

    Set cn = New ADODB.Connection
    cn.Open "Provider = Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=C:\Database\sales.accdb;"

    Set rs = New ADODB.Recordset

       sSQL = "SELECT * FROM PandR WHERE QID ='" & sQID & "';"

    rs.Open Source:=sSQL, ActiveConnection:=cn, LockType:=adLockOptimistic

        Do While lngRow <= LR

        With rs
            .Fields("QorB") = Cells(lngRow, 60).Value
            .Fields("BDate") = Cells(lngRow, 62).Value
            .update

        End With

    'Next rng
    lngRow = lngRow + 1       

    Loop    

    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing

End Sub

Answer 1

您正在硬编码以下行：`sQID = Cells（2，61）.Value

您应该将其替换为：

sQID = Cells(lngRow, 61).Value

然后它将取自下一行的值，而不是继续选择同一行。

更新：斯科特·霍尔兹曼（Scott Holzman）首先到达那里！

Answer 2

此代码应该可以按预期工作：

Sub updatedbtest2()

Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim rng As Range
Dim lngRow As Long
Dim sQID, LR
Dim sSQL As String

LR = Range("A" & Rows.Count).End(xlUp).Row
'Debug.Print LR

'Upd = LR - 1
lngRow = 2

Set cn = New ADODB.Connection
cn.Open "Provider = Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=C:\Database\sales.accdb;"

Do While lngRow <= LR

    sQID = Cells(lngRow, 61).Value

    Set rs = New ADODB.Recordset
    sSQL = "SELECT * FROM PandR WHERE QID ='" & sQID & "';"

    With rs
        .Open Source:=sSQL, ActiveConnection:=cn, LockType:=adLockOptimistic

        .Fields("QorB") = Cells(lngRow, 60).Value
        .Fields("BDate") = Cells(lngRow, 62).Value

        .Update

    End With

    'Next rng
    lngRow = lngRow + 1

    rs.Close
    Set rs = Nothing

Loop

cn.Close
Set cn = Nothing

End Sub