Excel VBA ADO query loop for too many rows

Question

I am trying to perform a query on an excel worksheet like I have done many times, but now the data has over 70k rows. Normally, I get the message that it cannot find the table if this is the case, which is to be expected since I think it stops working at around 65k rows or so.

So, what I am trying instead is doing a loop where in the first part of the loop I run the first 60k rows, and in every iteration of the loop it does another batch of 60k until it finishes with the last set. The loop creates a new sheet with the data to work with so I can have the column headers with the data set. It seems to work all the way up to the part where it runs a new query on the data from the new sheet. It gives me the error that "The Microsoft Access database engine could not find the object " (My Table Name)... etc.

For my specific example the table is "Sheet1$A1:N12790" where 12790 is the leftover number of rows from the over 70k row sheet and Sheet1 is the sheet that is created when you run the code.

So, I have absolutely no clue why it is giving this error when it usually only does it if there are too many rows or if the table definitely does not exist.

I tried running a simple Select * from [Sheet1$A1:N12790] with a separate sub, and it works perfectly. This leads me to believe that somehow maybe excel is running out of memory perhaps after doing the first one? But I have no idea what to do about it, and there is very little information on the web about this since it is so specific and rare since most people just use a regular database at this point.

Thanks!

UPDATE: I have been testing many things. I have tried creating a test sub to handle the new sheet (as explained above) and it works when run separately, but if I try and force the main sub to exit the loop sooner and then call the new test sub to run what I want it to do, it gives me the same error. So again, both subs run separately perfectly but I can't use the one to call the other. Shows me more proof that it is less about the coding and more about some sort of processing complication, but I still am just putting out theories.

Update 2: Thank you for all of the ideas and suggestions up till now (6/20/18). Here is a screenshot of what the error says when it runs through the second time and tries to run MySQL:

Error Message:

Here is my code below if it is helpful:

Sub Risk_Init_Pivot(FA_PQ, Risk_Init, SubChannel, MyMonth As String)

    Application.ScreenUpdating = False

    Dim SheetRange1 As Range, SheetRange2 As Range, SheetRange3 As Range, MyRange As Range
    Dim TargetSheetTable As String, SheetTable1 As String
    Dim SR1_LastRow As Double, SR1_LastColumn As Double, NewRowCount As Double, SR1_FirstRow As Double
    Dim i As Integer, j As Integer, MyLoop As Integer
    Dim Table1 As String, MySQL As String
    Dim MySheet1 As Worksheet, MySheet2 As Worksheet
    Dim MyConn As ADODB.Connection
    Dim MyRecordSet As ADODB.Recordset

    TargetSheetTable = "Risk Init Pivot"
    SheetTable1 = "Fanned File"

    'Initiate
    ActiveWorkbook.Sheets(TargetSheetTable).Activate

    If ActiveSheet.AutoFilterMode Then
        If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    End If

    ActiveSheet.Cells.ClearContents

    'Find Range Coordinates Dynamically
    ActiveWorkbook.Sheets(SheetTable1).Activate

    If ActiveSheet.AutoFilterMode Then
        If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    End If

    Range("A1").Select
    Selection.End(xlDown).Select
    SR1_LastRow = Selection.Row
    ActiveCell.SpecialCells(xlLastCell).Select
    SR1_LastColumn = Selection.Column
    Range("A1").Select

    MyLoop = WorksheetFunction.RoundUp(SR1_LastRow / 60000, 0)

    NewRowCount = 0

    For j = 1 To MyLoop

        'Set Up Connection Details
        Set MyConn = New ADODB.Connection
        MyConn.CommandTimeout = 0
        Set MyRecordSet = New ADODB.Recordset

        MyConn.Open "Provider = Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source = " & Application.ThisWorkbook.FullName & ";" & _
        "Extended Properties = ""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
        Set MyRecordSet.ActiveConnection = MyConn

        'First Time
        If SR1_LastRow > 60000 Then
            NewRowCount = SR1_LastRow - 60000
            SR1_LastRow = 60000
            SR1_FirstRow = 1

            'Set the tables equal to the respective ranges
            Set SheetRange1 = ActiveWorkbook.Sheets(SheetTable1).Range("A" & SR1_FirstRow & ":" & Cells(SR1_LastRow, SR1_LastColumn).Address)

            'Pass the table address to a string
            Table1 = SheetRange1.Address

            'Convert the string into a query table - have to get rid of dollar signs for it to work
            Table1 = "[" & SheetTable1 & "$" & Replace(Table1, "$", "") & "]"

        'Does this until NewRowCount falls into last time
        ElseIf NewRowCount > 60000 Then
            NewRowCount = NewRowCount - 60000
            SR1_FirstRow = SR1_LastRow + 1
            SR1_LastRow = SR1_LastRow + 60000

            Set MySheet1 = Sheets(SheetTable1)
            Sheets.Add After:=MySheet1
            Set MySheet2 = ActiveSheet

            MySheet1.Activate
            Rows("1:1").Select
            Selection.Copy
            MySheet2.Activate
            Rows("1:1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

            MySheet1.Activate
            ActiveSheet.Range("A" & SR1_FirstRow & ":" & Cells(SR1_LastRow, SR1_LastColumn).Address).Copy
            MySheet2.Activate
            ActiveSheet.Range("A2").PasteSpecial xlPasteValues
            Range("A1").Select
            Range(Selection, Selection.End(xlDown)).Select
            Range(Selection, Selection.End(xlToRight)).Select
            Set MyRange = Selection

            'Set the tables equal to the respective ranges
            Table1 = Selection.Address

            'Convert the string into a query table - have to get rid of dollar signs for it to work
            Table1 = "[" & MySheet2.Name & "$" & Replace(Table1, "$", "") & "]"

        'Last Time
        ElseIf (NewRowCount > 0) And (NewRowCount <= 60000) Then
            SR1_FirstRow = SR1_LastRow + 1
            SR1_LastRow = SR1_LastRow + NewRowCount
            NewRowCount = 0


            Set MySheet1 = Sheets(SheetTable1)
            Sheets.Add After:=MySheet1
            Set MySheet2 = ActiveSheet

            MySheet1.Activate
            Rows("1:1").Select
            Selection.Copy
            MySheet2.Activate
            Rows("1:1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

            MySheet1.Activate
            ActiveSheet.Range("A" & SR1_FirstRow & ":" & Cells(SR1_LastRow, SR1_LastColumn).Address).Copy
            MySheet2.Activate
            ActiveSheet.Range("A2").PasteSpecial xlPasteValues
            Range("A1").Select
            Range(Selection, Selection.End(xlDown)).Select
            Range(Selection, Selection.End(xlToRight)).Select

            'Set the tables equal to the respective ranges
            Table1 = Selection.Address

            'Convert the string into a query table - have to get rid of dollar signs for it to work
            Table1 = "[" & MySheet2.Name & "$" & Replace(Table1, "$", "") & "]"

        'Does this the first time if under 60k rows
        Else
            SR1_FirstRow = 1

            'Set the tables equal to the respective ranges
            Set SheetRange1 = ActiveWorkbook.Sheets(SheetTable1).Range("A" & SR1_FirstRow & ":" & Cells(SR1_LastRow, SR1_LastColumn).Address)

            'Pass the table address to a string
            Table1 = SheetRange1.Address

            'Convert the string into a query table - have to get rid of dollar signs for it to work
            Table1 = "[" & SheetTable1 & "$" & Replace(Table1, "$", "") & "]"

        End If

        'SQL Statement
        MySQL = Sheets("Control Sheet").Range("C14").Value          
        MySQL = Replace(MySQL, "@Table1", Table1)           
        MySQL = Replace(MySQL, "@Year", Sheets("Control Sheet").Range("C5").Value)          
        MySQL = Replace(MySQL, "@FA_PQ_Input", FA_PQ)           
        MySQL = Replace(MySQL, "@SubChannel", SubChannel)           
        MySQL = Replace(MySQL, "@MyMonth", MyMonth)

        MsgBox MySQL

        'Run SQL
        MyRecordSet.Open MySQL, MyConn, adOpenKeyset, adLockOptimistic

        'Paste Data with headers to location
        ActiveWorkbook.Sheets(TargetSheetTable).Activate
        ActiveSheet.Range("A" & 1 + SR1_FirstRow).CopyFromRecordset MyRecordSet

        For i = 0 To MyRecordSet.Fields.Count - 1
            ActiveSheet.Cells(1, i + 1) = MyRecordSet.Fields(i).Name
            With ActiveSheet.Cells(1, i + 1)
                .Font.Bold = True
                .Font.Size = 10
            End With
        Next i

        MyRecordSet.Close
        Set MyRecordSet = Nothing

        MyConn.Close
        Set MyConn = Nothing
    Next j

    ''Putting Nulls in the blanks
    'ActiveSheet.Cells.Replace What:="", Replacement:="NULL", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True, _
    '                          SearchFormat:=False, ReplaceFormat:=False

    'Tidying the sheet
    ActiveSheet.Cells.AutoFilter                
    ActiveSheet.Columns.AutoFit
    ActiveSheet.Range("A1").Select              
    Sheets("Control Sheet").Activate

    Application.ScreenUpdating = True
End Sub

Answer 1

Thanks to Xabier and Alan for their contributions to the solution.

Xabier for the cleaner code. Alan for identifying the underlying issue.

The issue is that when the original table gets split onto the new sheet to account for the excess rows, even though the sheet exists, the ADO was not recognizing it yet. It's not until you leave the current sub that it recognizes it (at least that is my understanding from all of the discussion, testing, and ultimately my solution).

So, as a high level summary:

1. To account for too many rows and getting the "Access cannot find your table" error message, I would let the first 60k run on the current sheet and then copy the next 60k (or less) to a new sheet.

2. In order for the ADO to recognize the newly created sheet, I placed the connection and recordset functionality into a separate sub and called it from within my original sub by passing any parameters that I needed it to have to run successfully.

3. I then came back to my original sub, deleted the newly created sheet, and then looped through this process again until I had accounted for the entire original sheet.

So, for example, 140k rows would run the first 60k on the original sheet, run the next 60k off of a new sheet, and the last 20k off of another new sheet.

The key really was to put the recordset into a new sub and call it, and this was only necessary because the ADO was not seeing the newly created sheets without first leaving the original sub.

Thanks for all input, and here is my code below in case you are interested. Please note the code will look similar (with some modifications) to the cleaner version that Xabier posted.

Sub Risk_Init_Pivot(FA_PQ As String, Risk_Init As String, SubChannel As String, MyMonth As String)

Application.ScreenUpdating = False


Dim SheetRange1 As Range, MyRange As Range
Dim SR1_LastRow As Double, SR1_LastColumn As Double, NewRowCount As Double, SR1_FirstRow As Double
Dim i As Integer, j As Integer, MyLoop As Integer
Dim Table1 As String, MySQL As String
Dim wsOrigin As Worksheet, wsTarget As Worksheet, MySheet As Worksheet
Set wsTarget = Sheets("Risk Init Pivot")
Set wsOrigin = Sheets("Fanned File")

'Initiate
wsTarget.Cells.ClearContents

'Find Range Coordinates Dynamically
If wsOrigin.AutoFilterMode Then
    If wsOrigin.FilterMode Then wsOrigin.ShowAllData
End If

SR1_LastRow = wsOrigin.Cells(wsOrigin.Rows.Count, "A").End(xlUp).Row
SR1_LastColumn = wsOrigin.Cells(SR1_LastRow, wsOrigin.Columns.Count).End(xlToLeft).Column


MyLoop = WorksheetFunction.RoundUp(SR1_LastRow / 60000, 0)

NewRowCount = 0

For j = 1 To MyLoop


    'First Time
    If SR1_LastRow > 60000 Then
        NewRowCount = SR1_LastRow - 60000
        SR1_LastRow = 0
        SR1_EndRow = 60000
        SR1_FirstRow = 1

        'Set the tables equal to the respective ranges
        Set SheetRange1 = wsOrigin.Range("A" & SR1_FirstRow & ":" & Cells(SR1_EndRow, SR1_LastColumn).Address)

        'Pass the table address to a string
        Table1 = SheetRange1.Address

        'Convert the string into a query table - have to get rid of dollar signs for it to work
        Table1 = "[" & wsOrigin.Name & "$" & Replace(Table1, "$", "") & "]"



    'Does this until NewRowCount falls into last time
    ElseIf NewRowCount > 60000 Then
        NewRowCount = NewRowCount - 60000
        SR1_FirstRow = SR1_EndRow + 1
        SR1_EndRow = SR1_FirstRow + 59999

        Sheets.Add After:=wsOrigin
        Set MySheet = ActiveSheet

        wsOrigin.Rows("1:1").Copy
        MySheet.Rows("1:1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

        wsOrigin.Range("A" & SR1_FirstRow & ":" & Cells(SR1_EndRow, SR1_LastColumn).Address).Copy
        MySheet.Range("A2").PasteSpecial xlPasteValues
        Set MyRange = MySheet.UsedRange

        'Set the tables equal to the respective ranges
        Table1 = MyRange.Address

        'Convert the string into a query table - have to get rid of dollar signs for it to work
        Table1 = "[" & MySheet.Name & "$" & Replace(Table1, "$", "") & "]"


    'Last Time
    ElseIf (NewRowCount > 0) And (NewRowCount <= 60000) Then
        SR1_FirstRow = SR1_EndRow + 1
        SR1_EndRow = SR1_FirstRow + NewRowCount
        NewRowCount = 0

        Sheets.Add After:=wsOrigin
        Set MySheet = ActiveSheet

        wsOrigin.Rows("1:1").Copy
        MySheet.Rows("1:1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

        wsOrigin.Range("A" & SR1_FirstRow & ":" & Cells(SR1_EndRow, SR1_LastColumn).Address).Copy
        MySheet.Range("A2").PasteSpecial xlPasteValues
        Set MyRange = MySheet.UsedRange

        'Set the tables equal to the respective ranges
        Table1 = MyRange.Address
        'Convert the string into a query table - have to get rid of dollar signs for it to work
        Table1 = "[" & MySheet.Name & "$" & Replace(Table1, "$", "") & "]"



    'Does this the first time if under 60k rows
    Else
        SR1_FirstRow = 1

        'Set the tables equal to the respective ranges
        Set SheetRange1 = wsOrigin.Range("A" & SR1_FirstRow & ":" & Cells(SR1_LastRow, SR1_LastColumn).Address)

        'Pass the table address to a string
        Table1 = SheetRange1.Address

        'Convert the string into a query table - have to get rid of dollar signs for it to work
        Table1 = "[" & wsOrigin.Name & "$" & Replace(Table1, "$", "") & "]"


    End If


    Call MyRecordset(Table1, FA_PQ, SubChannel, MyMonth, wsTarget)

    If Not MySheet Is Nothing Then
    Application.DisplayAlerts = False
    MySheet.Delete
    Application.DisplayAlerts = True
    End If

Next j

'Tidying the sheet
wsTarget.Cells.AutoFilter
wsTarget.Columns.AutoFit
Sheets("Control Sheet").Activate

Application.ScreenUpdating = True

End Sub

Sub MyRecordset(Table1 As String, FA_PQ As String, SubChannel As String, MyMonth As 
String, wsTarget As Worksheet)


    Dim MyConn As ADODB.Connection
    Dim MyRecordset As ADODB.RecordSet
    Dim i As Integer
    Dim LastRow As Double


    'Set Up Connection Details
    Set MyConn = New ADODB.Connection
    MyConn.CommandTimeout = 0
    Set MyRecordset = New ADODB.RecordSet

    MyConn.Open "Provider = Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source = " & Application.ThisWorkbook.FullName & ";" & _
    "Extended Properties = ""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
    Set MyRecordset.ActiveConnection = MyConn

    'SQL Statement
    MySQL = Sheets("Control Sheet").Range("C14").Value
    MySQL = Replace(MySQL, "@Table1", Table1)
    MySQL = Replace(MySQL, "@Year", Sheets("Control Sheet").Range("C5").Value)
    MySQL = Replace(MySQL, "@FA_PQ_Input", FA_PQ)
    MySQL = Replace(MySQL, "@SubChannel", SubChannel)
    MySQL = Replace(MySQL, "@MyMonth", MyMonth)

    'Run SQL

    MyRecordset.Open MySQL, MyConn, adOpenKeyset, adLockOptimistic


    'Paste Data with headers to location
    If wsTarget.Range("A2").Value = "" Then
    wsTarget.Range("A2").CopyFromRecordset MyRecordset
    Else
    LastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
    wsTarget.Range("A" & LastRow + 1).CopyFromRecordset MyRecordset
    End If

    For i = 0 To MyRecordset.Fields.Count - 1
        wsTarget.Cells(1, i + 1) = MyRecordset.Fields(i).Name
        With wsTarget.Cells(1, i + 1)
            .Font.Bold = True
            .Font.Size = 10
        End With
    Next i

    MyRecordset.Close
    Set MyRecordset = Nothing

    MyConn.Close
    Set MyConn = Nothing



    'Putting Nulls in the blanks
    wsTarget.Cells.Replace What:="", Replacement:="0", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, ReplaceFormat:=False


End Sub