如何优化Excel VBA与Access的数据交互速度？

问题背景 #

通过Excel VBA开发的UserForm，将多个ListBox中的字符串信息同步到Access数据库：

• 第一循环遍历ListBox1，检查元素是否存在于数据库，不存在则执行插入
• 第二循环遍历ListBox2：元素存在则更新对应CheckBox状态，不存在则执行插入
• 当前痛点：Access数据更新存在延迟，第二循环无法识别第一循环刚插入的记录，必须强制等待5秒才能正常执行，多组循环场景下耗时无法接受

现有等待代码：

'Wait for the database to update
cnt.Update
Application.Wait Now + #12:00:05 AM#

核心循环代码：

For X = 0 To ListBox1.ListCount - 1
    'Look for duplicates
    If ((Access.Application.DCount("*", "Table1", "ID ='" & IdentificationCode & "' AND DWG = '" & ListBox1.List(X) & "'") > 0) Or IsNull(ListBox1.List(X)) = True) Then
        'MsgBox "Element already in the DB"
    Else
        On Error Resume Next
        
        'Insert the data into the recordset
        insert1 = "insert into Table1(" _
        & "ID," _
        & "DWG," _
        & "CheckBox1)" _
        & "values(" _
        & "'" & IdentificationCode & "'," _
        & "'" & ListBox1.List(X) & "'," _
        & "-1)"
        
        cnt.Execute (insert1)
    End If
Next X

If (ListBox2.ListCount > 0) Then
    'Wait for the database to update
    cnt.Update
    Application.Wait Now + #12:00:05 AM#

    For X = 0 To ListBox2.ListCount - 1
        'Look for duplicates
        If ((Access.Application.DCount("*", "Table1", "ID ='" & IdentificationCode & "' AND DWG = '" & ListBox2.List(X) & "'") > 0)) Then 'Or IsNull(ListBox2.List(X)) = True)
            'MsgBox "Element already in the DB"
            On Error Resume Next
            
            update1 = "update Table1 set" _
            & "[Table2].CheckBox2 ='-1'" _
            & "where [Table2].ID ='" & IdentificationCode & "'" _
            & "and [Table2].DWG ='" & ListBox2.List(X) & "';"
            
            cnt.Execute (update1)
        Else
            On Error Resume Next
            
            'Insert the data into the recordset
            insert2 = "insert into Table1(" _
            & "ID," _
            & "DWG," _
            & "CheckBox2)" _
            & "values(" _
            & "'" & IdentificationCode & "'," _
            & "'" & ListBox2.List(X) & "'," _
            & "-1)"
            
            cnt.Execute (insert2)
        End If
    Next X
End If

注：循环前已初始化并打开ADODB.Connection对象cnt

优化方案 #

1. 本地缓存已处理记录，消除数据库延迟依赖 #

将第一循环插入的记录存入本地字典，第二循环直接通过字典判断记录是否存在，无需再查询数据库，彻底解决延迟问题。

示例代码：

Dim processedItems As Object
Set processedItems = CreateObject("Scripting.Dictionary")

' 处理ListBox1，同步缓存已插入的(ID+DWG)组合
For X = 0 To ListBox1.ListCount - 1
    Dim key As String
    key = IdentificationCode & "|" & ListBox1.List(X)
    
    If IsNull(ListBox1.List(X)) Then
        Continue For ' 跳过空值
    End If
    
    ' 先查本地缓存，再查数据库（覆盖数据库已存在的记录）
    If processedItems.Exists(key) Or cnt.Execute("SELECT COUNT(*) FROM Table1 WHERE ID='" & IdentificationCode & "' AND DWG='" & ListBox1.List(X) & "'").Fields(0).Value > 0 Then
        ' 记录已存在，跳过
    Else
        insert1 = "INSERT INTO Table1(ID, DWG, CheckBox1) VALUES('" & IdentificationCode & "', '" & ListBox1.List(X) & "', -1)"
        cnt.Execute insert1
        processedItems.Add key, True ' 加入本地缓存
    End If
Next X

' 处理ListBox2，直接用本地缓存判断
If ListBox2.ListCount > 0 Then
    For X = 0 To ListBox2.ListCount - 1
        Dim key2 As String
        key2 = IdentificationCode & "|" & ListBox2.List(X)
        
        If IsNull(ListBox2.List(X)) Then
            Continue For
        End If
        
        ' 判断记录是否存在：缓存有 或 数据库已有
        Dim existsInDB As Boolean
        existsInDB = processedItems.Exists(key2) Or cnt.Execute("SELECT COUNT(*) FROM Table1 WHERE ID='" & IdentificationCode & "' AND DWG='" & ListBox2.List(X) & "'").Fields(0).Value > 0
        
        If existsInDB Then
            ' 修复原代码错误：UPDATE语句不应引用Table2，目标表是Table1
            update1 = "UPDATE Table1 SET CheckBox2 = -1 WHERE ID='" & IdentificationCode & "' AND DWG='" & ListBox2.List(X) & "'"
            cnt.Execute update1
        Else
            insert2 = "INSERT INTO Table1(ID, DWG, CheckBox2) VALUES('" & IdentificationCode & "', '" & ListBox2.List(X) & "', -1)"
            cnt.Execute insert2
            processedItems.Add key2, True ' 加入缓存
        End If
    Next X
End If

2. 使用参数化查询，提升速度+避免SQL注入 #

直接拼接SQL字符串会增加数据库解析开销，且存在SQL注入风险。改用ADODB.Command参数化查询，减少重复解析成本，同时提升安全性。

示例代码（插入操作）：

Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
cmd.ActiveConnection = cnt
cmd.CommandType = adCmdText

' 定义参数化插入模板
cmd.CommandText = "INSERT INTO Table1(ID, DWG, CheckBox1) VALUES(?, ?, -1)"

' 添加参数（长度根据实际字段调整）
Dim paramID As ADODB.Parameter
Set paramID = cmd.CreateParameter("ID", adVarChar, adParamInput, 50)
cmd.Parameters.Append paramID

Dim paramDWG As ADODB.Parameter
Set paramDWG = cmd.CreateParameter("DWG", adVarChar, adParamInput, 100)
cmd.Parameters.Append paramDWG

' 处理ListBox1
For X = 0 To ListBox1.ListCount - 1
    If IsNull(ListBox1.List(X)) Then Continue For
    
    key = IdentificationCode & "|" & ListBox1.List(X)
    If Not processedItems.Exists(key) And cnt.Execute("SELECT COUNT(*) FROM Table1 WHERE ID=? AND DWG=?", Array(IdentificationCode, ListBox1.List(X))).Fields(0).Value = 0 Then
        paramID.Value = IdentificationCode
        paramDWG.Value = ListBox1.List(X)
        cmd.Execute
        processedItems.Add key, True
    End If
Next X

3. 批量执行SQL语句，减少数据库交互次数 #

将多个插入/更新语句合并为一个批量语句，一次性提交给数据库，降低往返通信开销。

示例代码：

Dim insertBatch As String
insertBatch = ""

' 收集ListBox1需要插入的语句
For X = 0 To ListBox1.ListCount - 1
    If IsNull(ListBox1.List(X)) Then Continue For
    
    key = IdentificationCode & "|" & ListBox1.List(X)
    If Not processedItems.Exists(key) And cnt.Execute("SELECT COUNT(*) FROM Table1 WHERE ID='" & IdentificationCode & "' AND DWG='" & ListBox1.List(X) & "'").Fields(0).Value = 0 Then
        insertBatch = insertBatch & "INSERT INTO Table1(ID, DWG, CheckBox1) VALUES('" & IdentificationCode & "', '" & ListBox1.List(X) & "', -1);"
        processedItems.Add key, True
    End If
Next X

' 执行批量插入
If insertBatch <> "" Then
    cnt.Execute insertBatch
End If

4. 开启事务批量提交，减少磁盘IO #

默认ADODB.Connection为自动提交模式，每执行一条SQL就写入磁盘。开启手动事务，处理完所有操作后统一提交，大幅减少磁盘IO次数。

示例代码：

cnt.BeginTrans ' 启动事务

' 此处放置ListBox1和ListBox2的所有处理代码...

cnt.CommitTrans ' 提交所有更改
' 若执行出错，可回滚：cnt.RollbackTrans

5. 修复原代码中的错误 #

• UPDATE语句错误引用[Table2]，实际目标表为Table1，会导致执行失败
• 避免滥用On Error Resume Next，建议捕获具体错误，防止隐藏逻辑问题

内容的提问来源于stack exchange，提问作者busynessman