I have a VBA module that receives a database object, worksheet name, and two column field names as parameters to make a SQL query into another Excel table that has over 1,000,000 rows with information. But when I was debugging I noticed that my VBA code does not return the info after the row number 65,000 (approximately). This is returning wrong info and not acting properly as expected.
So, how can I handle it in my existing code?
Here is my code:
Functions
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
Main Subroutine
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
