使用 SQL 语言使用 DAO 时，为什么 VBA 没有到达行号 65,000 之后的数据？

问题描述

我有一个 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,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,"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,NOME_PLANILHA & 2,Query)
            End If
        Next i
        wb.Close        
    End If
    
Else
    MsgBox "Texto da Célula ativa não é CGC/CNPJ,impossível fazer pesquisa","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 格式 (.xls) 将工作表限制为 2^16 (65536) 行。当前的 Excel 格式 (.xlsx) 将工作表限制为 2^20 (1,048,576) 行。

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

来自

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

到

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