为什么在使用 SQL 语言的 DAO 时，VBA 无法获取行号 65,000 之后的数据？

Question

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

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

这是我的代码：

函数

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

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")

为什么在使用 SQL 语言的 DAO 时，VBA 无法获取行号 65,000 之后的数据？

Why does VBA doesn't reach data after Row number 65,000 when using DAO with SQL language?

sql

excel

vba

dao