将ADODB RecordSet转为二维数组时遇RecordCount返回-1问题

问题背景 #

使用ADODB连接读取Excel文件并将数据存入二维数组时，即便设置了adOpenStatic游标类型，rs.RecordCount始终返回-1。希望先获取符合条件的记录总数来直接初始化数组（避免频繁ReDim Preserve），但单独用COUNT(*)查询会丢失字段信息，组合字段与COUNT(*)的查询又报错。

核心原因 #

ACE OLEDB驱动对Excel数据源的RecordCount返回逻辑特殊：默认情况下静态游标不会立即加载所有记录，导致无法直接获取准确计数；另外原代码通过VBA过滤记录（rs.Fields(3).Value <> ""），直接用总记录数初始化数组会造成空间浪费。

解决方案 #

方案1：将过滤逻辑整合到SQL，通过游标移动获取准确计数 #

把过滤条件加入SQL查询，再通过移动游标加载所有记录以获取准确的符合条件的记录数，最后初始化数组：

Sub ReadExcelFileWithoutOpening()
    Dim conn As Object
    Dim rs As Object
    Dim filePath As String
    Dim sheetName As String
    Dim query As String

    filePath = "path to the excelfile"
    sheetName = "Sheet1"

    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")

    ' Excel 2007+连接字符串
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
              "Data Source=" & filePath & ";" & _
              "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    ' 过滤[NO FP NEW]不为空的记录，直接返回符合条件的数据
    query = "SELECT [Application],[Description],[Department],[NO FP NEW], [NO FP Changed], [NO FP DEL#], [Rapporting Period] " & _
            "FROM [" & sheetName & "$] " & _
            "WHERE [NO FP NEW] IS NOT NULL AND [NO FP NEW] <> ''"

    rs.Open query, conn, adOpenStatic

    Dim ID_Array() As String
    Dim index As Integer: index = 0
    Dim recordCount As Integer

    ' 移动游标到末尾加载所有记录，获取准确计数
    rs.MoveLast
    recordCount = rs.RecordCount
    rs.MoveFirst ' 移回记录开头准备遍历

    ' 初始化二维数组（符合条件的记录数 × 7列）
    ReDim ID_Array(recordCount - 1, 6)

    ' 遍历填充数组
    Do Until rs.EOF
        ID_Array(index, 0) = CStr(rs.Fields(0).Value)
        ID_Array(index, 1) = CStr(rs.Fields(1).Value)
        ID_Array(index, 2) = CStr(rs.Fields(2).Value)
        ID_Array(index, 3) = CStr(rs.Fields(3).Value)
        ID_Array(index, 4) = CStr(rs.Fields(4).Value)
        ID_Array(index, 5) = CStr(rs.Fields(5).Value)
        ID_Array(index, 6) = CStr(rs.Fields(6).Value)

        index = index + 1
        rs.MoveNext
    Loop

    ' 清理资源
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
End Sub

方案2：先遍历计数再填充数组（无需修改SQL） #

如果不想调整SQL语句，可先遍历一次统计符合条件的记录数，再初始化数组并重新遍历填充：

Sub ReadExcelFileWithoutOpening()
    Dim conn As Object
    Dim rs As Object
    Dim filePath As String
    Dim sheetName As String
    Dim query As String

    filePath = "path to the excelfile"
    sheetName = "Sheet1"

    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")

    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
              "Data Source=" & filePath & ";" & _
              "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    query = "SELECT [Application],[Description],[Department],[NO FP NEW], [NO FP Changed], [NO FP DEL#], [Rapporting Period] " & _
            "FROM [" & sheetName & "$]"

    rs.Open query, conn, adOpenStatic

    Dim ID_Array() As String
    Dim index As Integer: index = 0
    Dim validCount As Integer: validCount = 0

    ' 第一次遍历：统计符合条件的记录数
    Do Until rs.EOF
        If rs.Fields(3).Value <> "" Then
            validCount = validCount + 1
        End If
        rs.MoveNext
    Loop
    rs.MoveFirst ' 移回记录开头

    ' 初始化二维数组
    ReDim ID_Array(validCount - 1, 6)

    ' 第二次遍历：填充数组
    Do Until rs.EOF
        If rs.Fields(3).Value <> "" Then
            ID_Array(index, 0) = CStr(rs.Fields(0).Value)
            ID_Array(index, 1) = CStr(rs.Fields(1).Value)
            ID_Array(index, 2) = CStr(rs.Fields(2).Value)
            ID_Array(index, 3) = CStr(rs.Fields(3).Value)
            ID_Array(index, 4) = CStr(rs.Fields(4).Value)
            ID_Array(index, 5) = CStr(rs.Fields(5).Value)
            ID_Array(index, 6) = CStr(rs.Fields(6).Value)
            index = index + 1
        End If
        rs.MoveNext
    Loop

    ' 清理资源
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
End Sub

关键说明 #

• adOpenStatic游标需要先执行rs.MoveLast，才能让RecordCount返回准确值——Excel驱动不会默认将所有记录加载到内存。
• 将过滤逻辑整合到SQL中，既能减少内存占用，又能直接获取符合条件的记录数，是更高效的方案。
• 若必须保留VBA端过滤，两次遍历的开销远低于两次独立的SQL查询。

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