如何高效将Access表50万数据导入Excel VBA的Dictionary？

问题背景 #

需要将Access表（2000行×250列，共50万数据点）导入Excel VBA的Scripting.Dictionary，每个数据点对应唯一键用于后续字典间计算。当前逐场景逐数据点拉取的方案耗时约3小时，Access数据读取占比最大；曾尝试数组方案但耗时更长，Dictionary比数组快25%，期望找到更高效的批量读取方案或数组+Dictionary的混合优化方式。

当前代码片段 #

主逻辑代码 #

Dim i As Long, j As Long, k As Long, strClass As String
Dim dictReturn As Object: Set dictReturn = CreateObject("Scripting.Dictionary")
For i = 1 To 25   'i represents one of 25 individual asset classes
    For k = 2023 To (2023 + 9)
        strClass = cltClassesConning(i) & " " & k   'k represents the year for a given asset class over time
        strClassPath = strClass & "_" & j   'j represents the current scenario out of the 2,000 overall
        Dim abc: abc = return_individual(strClass, j)  'this function returns each item in a given row one after another and puts it into a dictionary: see below for function code
        If Not dictReturn.Exists(strClass) Then dictReturn.Add strClassPath, abc(strClass).Value
    Next k
Next i

Access数据读取函数 #

Public Function return_individual(strClass As String, j As Integer) As ADODB.recordset
'-------------------------------------------------
Dim fileName As String: fileName = ThisWorkbook.Path & Application.PathSeparator & "[name of Access database].accdb"
Dim cntName As String: cntName = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
                                    & fileName & ";Persist Security Info=False;"

Dim cnt As Object: Set cnt = CreateObject("ADODB.connection")
cnt.Open cntName

Dim rs As Object: Set rs = CreateObject("ADODB.Recordset")
Dim query As String: query = "SELECT [" & strClass & "] FROM input_table WHERE Scenario=" & j & ";"

rs.Source = query
rs.ActiveConnection = cnt
rs.Open

Set return_individual = rs
'-------------------------------------------------
End Function

核心优化方案 #

1. 一次性读取全表到数组，再转存Dictionary（最优方案） #

当前代码最大的性能损耗是每次查询都新建数据库连接+单列查询（共2000×250次查询），改为一次性读取全表数据到数组，再遍历数组生成Dictionary，可将读取时间压缩到分钟级。

示例代码

Sub BatchImportToDict()
    Dim dictReturn As Object: Set dictReturn = CreateObject("Scripting.Dictionary")
    Dim conn As Object, rs As Object
    Dim arrData As Variant
    Dim colIndex As Long, rowIndex As Long
    Dim strClass As String, strKey As String
    Dim fileName As String, cntName As String
    
    ' 初始化数据库连接（仅打开一次）
    fileName = ThisWorkbook.Path & Application.PathSeparator & "[name of Access database].accdb"
    cntName = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & fileName & ";Persist Security Info=False;"
    Set conn = CreateObject("ADODB.Connection")
    conn.Open cntName
    
    ' 一次性读取全表，使用静态游标提升读取效率
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open "SELECT * FROM input_table", conn, adOpenStatic, adLockReadOnly
    
    ' 将Recordset转为二维数组（注意：GetRows返回[列,行]结构，与Excel数组的[行,列]相反）
    arrData = rs.GetRows
    
    ' 关闭连接释放资源
    rs.Close: Set rs = Nothing
    conn.Close: Set conn = Nothing
    
    ' 建立列名与数组索引的映射Dictionary，方便快速查找列位置
    Dim colMap As Object: Set colMap = CreateObject("Scripting.Dictionary")
    For colIndex = 0 To UBound(arrData, 1)
        colMap(rs.Fields(colIndex).Name) = colIndex
    Next colIndex
    
    ' 遍历数组生成目标Dictionary
    For rowIndex = 0 To UBound(arrData, 2)
        Dim scenarioNum As Long: scenarioNum = rowIndex + 1 ' 数组行索引从0开始，对应原场景1~2000
        For i = 1 To 25
            For k = 2023 To 2032
                strClass = cltClassesConning(i) & " " & k
                strKey = strClass & "_" & scenarioNum
                ' 直接赋值，Dictionary自动处理不存在的键（无需Exists判断，提升效率）
                If colMap.Exists(strClass) Then
                    dictReturn(strKey) = arrData(colMap(strClass), rowIndex)
                End If
            Next k
        Next i
    Next rowIndex
End Sub

2. 按场景批量查询列（次优方案） #

若不想一次性读取全表，可改为每个场景查询一次所有列（共2000次查询），替代原来的单列多次查询，大幅减少数据库交互次数。

示例代码片段

Sub BatchQueryPerScenario()
    Dim dictReturn As Object: Set dictReturn = CreateObject("Scripting.Dictionary")
    Dim conn As Object, rs As Object
    Dim fileName As String, cntName As String
    Dim j As Long, i As Long, k As Long
    Dim strClass As String, strKey As String
    
    ' 仅打开一次数据库连接
    fileName = ThisWorkbook.Path & Application.PathSeparator & "[name of Access database].accdb"
    cntName = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & fileName & ";Persist Security Info=False;"
    Set conn = CreateObject("ADODB.Connection")
    conn.Open cntName
    
    For j = 1 To 2000
        ' 查询当前场景的所有列
        Set rs = CreateObject("ADODB.Recordset")
        rs.Open "SELECT * FROM input_table WHERE Scenario = " & j, conn, adOpenStatic, adLockReadOnly
        
        If Not rs.EOF Then
            For i = 1 To 25
                For k = 2023 To 2032
                    strClass = cltClassesConning(i) & " " & k
                    strKey = strClass & "_" & j
                    ' 直接赋值，无需Exists判断
                    dictReturn(strKey) = rs.Fields(strClass).Value
                Next k
            Next i
        End If
        rs.Close: Set rs = Nothing
    Next j
    
    conn.Close: Set conn = Nothing
End Sub

3. 数组+Dictionary混合方案的高效实践 #

• 用数组批量读取：所有数据库操作只做一次或少数几次，将数据加载到内存数组，避免频繁的数据库IO
• 用Dictionary做快速映射：比如列名到数组索引的映射，或者最终计算用的键值对
• 避免冗余判断：Dictionary直接赋值dictReturn(strKey) = value即可自动处理新键，无需提前用Exists判断，减少循环内的逻辑开销

内容的提问来源于stack exchange，提问作者art-i-fex