为啥在 SQL 语言中使用 DAO 时 VBA 无法到达第 65,000 行之后的数据？

Posted 2023-04-18

【中文标题】为啥在 SQL 语言中使用 DAO 时 VBA 无法到达第 65,000 行之后的数据？

【英文标题】：Why does VBA doesn't reach data after Row number 65,000 when using DAO with SQL language?为什么在 SQL 语言中使用 DAO 时 VBA 无法到达第 65,000 行之后的数据？

【发布时间】：2021-09-01 07:37:09

【问题描述】：

我有一个 VBA 模块，它接收一个数据库对象、工作表名称和两个列字段名称作为参数，以便对另一个具有超过 1,000,000 行信息的 Excel 表进行 SQL 查询。但是当我调试时，我注意到我的 VBA 代码在行号 65,000（大约）之后没有返回信息。这将返回错误信息，并且未按预期正常运行。

那么，如何在我现有的代码中处理它？

这是我的代码：

函数

Const diretoriosA = "C:\Users\Bosch-PC\Desktop\dbLEGENDAS_ELETROPAR\"
Const BaseEletro = "dbClientesEletropar.xlsb"
Const dbClientes = "CLIENTESLDA"

Public Function Number2Letter(ByVal ColNum As Long) As String

    Dim ColumnNumber As Long
    Dim ColumnLetter As String
    
    ColumnNumber = ColNum
    ColumnLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)
    Number2Letter = ColumnLetter
    
End Function

Public Function GetWorkbook(ByVal sFullName As String) As Workbook

    Dim sFile As String
    Dim wbReturn As Workbook

    sFile = DIR(sFullName)

    On Error Resume Next
    
    Set wbReturn = Workbooks(sFile)

        If wbReturn Is Nothing Then        
            Set wbReturn = Workbooks.Open(sFullName)            
        End If
        
    On Error GoTo 0

    Set GetWorkbook = wbReturn

End Function

Public Function ReplaceChars(ByVal str As String, ByVal Lista As String) As String

    Dim buff(), buffChars() As String
    ReDim buff(Len(str) - 1): ReDim buffChars(Len(Lista) - 1)
    
    For i = 1 To Len(str):   buff(i - 1) = Mid$(str, i, 1):        Next
    For i = 1 To Len(Lista): buffChars(i - 1) = Mid$(Lista, i, 1): Next
    
    For strEle = 0 To UBound(buff)
        For listaEle = 0 To UBound(buffChars)
            If buff(strEle) = buffChars(listaEle) Then
                buff(strEle) = ""
            End If
        Next listaEle
        novoTexto = novoTexto & buff(strEle)
    Next strEle
    
    ReplaceChars = novoTexto
    
End Function

Function ConsultaBaseDeDadosELETRO(ByVal CAMPO_PESQUISA As String, _
                                   ByVal CAMPO_RETORNO As String, _
                                   ByVal NOME_PLANILHA As String, _
                                   ByRef BASES As Object, _
                                   ByVal ARGUMENTO As String) As String
On Error GoTo ERRO:

        Debug.Print BASES.Name

        Dim RSt22 As Recordset
        Set RSt22 = BASES.OpenRecordset("SELECT [" & CAMPO_RETORNO & "] FROM [" & NOME_PLANILHA & "$] WHERE [" & CAMPO_PESQUISA & "] IN ('" & ARGUMENTO & "') ;", dbOpenForwardOnly, dbReadOnly)
        Debug.Print RSt22.CacheSize & " | CONTAGEM: " & RSt22.RecordCount
        ConsultaBaseDeDadosELETRO = RSt22(CAMPO_RETORNO)
        Exit Function
ERRO:
    Debug.Print VBA.Err.Description & " | Error number: " & VBA.Err.Number & " | " & VBA.Err.HelpFile
    ConsultaBaseDeDadosELETRO = "Sem registros"
End Function

主子程序

Sub ProcurarBaseEletro(ByVal PASTA As String, ByVal ARQUIVO As String, ByVal NOME_PLANILHA As String, ByVal CAMPO As String)

If ActiveCell.value = "CGC" Or ActiveCell.value = "CNPJ" Or ActiveCell.value = "cgc" Or ActiveCell.value = "cnpj" Then

    Application.ScreenUpdating = False
    Dim wks As Worksheet: Set wks = ActiveSheet
    Dim db2 As database
    Dim CellRow As Single
    Dim Cellcol_info, CellCol As String
    Dim DiretorioBase As String: DiretorioBase = diretorioSA & BaseEletro
    Dim wb As Workbook: Set wb = GetWorkbook(DiretorioBase)

    If wb Is Nothing Then        
        MsgBox "Base de dados não localizada!" & vbNewLine & "EM: " & DiretorioBase, vbCritical, "Atenção"
        Set wb = Nothing
        Set wks = Nothing
        Application.ScreenUpdating = True
        Exit Sub
        
    Else    
        wks.Activate
        CellRow = ActiveCell.row
        CellCol = Number2Letter(ActiveCell.Column)
        Cellcol_info = Number2Letter(ActiveCell.Column + 1)
        CELLCOL_LROW = ActiveSheet.Cells(ActiveSheet.Rows.Count, CellCol).End(xlUp).row
        Set db2 = OpenDatabase(DiretorioBase, False, False, "Excel 8.0")
        Columns(Cellcol_info & ":" & Cellcol_info).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        Range(Cellcol_info & CellRow).value = CAMPO
        Dim Query As String
        Dim CelAtivaValue As String
        For i = CellRow + 1 To CELLCOL_LROW
            CelAtivaValue = UCase(Cells(i, CellCol).value)
            Query = ReplaceChars(CelAtivaValue, "/.- ")
            
            If Left(Query, 6) < 132714 Then
                Cells(i, Cellcol_info).value = ConsultaBaseDeDadosELETRO("CGC", CAMPO, NOME_PLANILHA, db2, Query)
            Else
                Cells(i, Cellcol_info).value = ConsultaBaseDeDadosELETRO("CGC", CAMPO, NOME_PLANILHA & 2, db2, Query)
            End If
        Next i
        wb.Close        
    End If
    
Else
    MsgBox "Texto da Célula ativa não é CGC/CNPJ, impossível fazer pesquisa", vbCritical, "Valor célula ativa: " & ActiveCell.value
    Application.ScreenUpdating = True
    Exit Sub    
End If

Cells.EntireColumn.AutoFit
MsgBox "Processo concluído com sucesso.", vbOKOnly, "Informativo do sistema"
Application.ScreenUpdating = True

End Sub

【问题讨论】：

听起来可能是驱动程序问题，旧版 Excel 中的最大行数为 65000 行，因此您可能需要使用不同的连接字符串或不同的连接字符串选项。跨度>

您将 Excel 8 指定为文件格式。该格式只能有 65536 行。

Rory，那还有什么办法呢？

您是否仍在使用旧版 Excel 工作簿 (.xls) 1997-2003？考虑以较新的格式保存工作簿 .xlsx (2007-2019) 和/或为 OpenDatabase 使用较新的连接选项。见this answer。

【参考方案1】：

旧版 Excel 格式 (.xls) 的工作表限制为 2^16 (65536) 行。当前 Excel 格式 (.xlsx) 的工作表限制为 2^20 (1,048,576) 行。

您可能拥有更新版本的 MS Office (2007+)（给定 BaseEletro 中的 .xlsb），但您的 DAO 代码未更新。考虑将DAO.OpenDatabase 选项调整为较新的当前格式。

来自

Set db2 = OpenDatabase(DiretorioBase, False, False, "Excel 8.0")

到

Set db2 = OpenDatabase(DiretorioBase, False, False, "Excel 12.0 Xml")

【讨论】：

它显示以下消息：runtime error 3170 Could not find installable ISAM。我目前正在使用 MSOFFICE 2007 顺便说一句。

你使用的是什么 DAO 库？检查 VB 编辑器，工具\参考。

Microsoft DAO 3.6 Object Library

请取消选中该引用并改为选中 Microsoft Office x.x Access database engine Object library。这允许访问支持当前 Excel .xlsx 和 Access .accdb 格式的较新的 ACE 引擎。如果您没有此参考，请尝试安装此MS download，即使它适用于 Office 2010。Office 2007 和 2010 的 10 年支持结束已经过去。考虑升级以避免错误和安全问题。

是的，因为这个解决方案建议使用Excel 12.0 Xml。