Цикл запроса Excel VBA ADO для слишком большого количества строк

Я считаю, что в вашем коде есть ряд проблем, и это не обязательно ответ на вашу проблему, но я попытался привести ваш код в порядок и удалить все операторы Select & Activate, поскольку они на самом деле не нужны и иногда могут вызывать ошибки. когда у вас активированы другие листы и т. д.

Пожалуйста, взгляните на приведенный ниже код, и, надеюсь, вы можете получить некоторые указатели:

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 SR1_LastRow As Double, SR1_LastColumn As Double, NewRowCount As Double, SR1_FirstRow As Double
    Dim i As Long, j As Long, MyLoop As Long
    Dim Table1 As String, MySQL As String
    Dim MySheet2 As Worksheet
    Dim MyConn As ADODB.Connection
    Dim MyRecordSet As ADODB.Recordset
    Dim wsFanned As Worksheet, wsTarget As Worksheet
    Set wsTarget = Sheets("Risk Init Pivot")
    Set wsFanned = Sheets("Fanned File")

    'Initiate
    wsTarget.Cells.Delete

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

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

    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 = wsFanned.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 = "[" & wsFanned.Name & "$" & 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

            Sheets.Add After:=wsFanned
            Set MySheet2 = ActiveSheet

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

            wsFanned.Range("A" & SR1_FirstRow & ":" & Cells(SR1_LastRow, SR1_LastColumn).Address).Copy
            MySheet2.Range("A2").PasteSpecial xlPasteValues
            Set MyRange = MySheet2.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 = "[" & 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


            Sheets.Add After:=wsFanned
            Set MySheet2 = ActiveSheet

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

            wsFanned.Range("A" & SR1_FirstRow & ":" & Cells(SR1_LastRow, SR1_LastColumn).Address).Copy
            MySheet2.Range("A2").PasteSpecial xlPasteValues

            'Set the tables equal to the respective ranges
            Table1 = MySheet2.UsedRange
            '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 = wsFanned.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
        wsTarget.Range("A" & 1 + SR1_FirstRow).CopyFromRecordset MyRecordSet

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

Excel считает, что ваш набор записей пуст.

Это не ошибка памяти.

С 80 тыс. строк ваш код входит в блок ElseIf (NewRowCount > 0) And (NewRowCount <= 60000) Then. Когда он пытается вызвать связанный набор записей, происходит сбой.

Вы можете проверить это поведение, изменив эту строку кода:

MyRecordSet.Open MySQL, MyConn, adOpenKeyset, adLockOptimistic

to:

On Error Resume Next
MyRecordSet.Open MySQL, MyConn, adOpenKeyset, adLockOptimistic
If MyRecordSet.EOF Then MsgBox "null"

Код работает правильно на первой итерации, на второй итерации вы получаете нулевое предупреждение.

Почему он не возвращает записи, я не могу вам сказать. Но вот ваша ошибка.

Спасибо Xabier и Alan за их вклад в решение.

Xabier за более чистый код. Алану за выявление основной проблемы.

Проблема в том, что когда исходная таблица разбивается на новый лист для учета лишних строк, даже если лист существует, ADO еще не распознает его. Он распознает его только после того, как вы покинете текущую подпрограмму (по крайней мере, это мое понимание из всех обсуждений, тестирования и, в конечном итоге, моего решения).

Итак, в качестве резюме высокого уровня:

1. Чтобы учесть слишком много строк и получить сообщение об ошибке «Доступ не может найти вашу таблицу», я бы позволил первым 60 КБ работать на текущем листе, а затем скопировал следующие 60 КБ (или меньше) на новый лист.

2. Чтобы ADO распознал только что созданный лист, я поместил функциональность соединения и набора записей в отдельную подпрограмму и вызвал ее из своей исходной подпрограммы, передав любые параметры, которые мне нужны для ее успешного запуска.

3. Затем я вернулся к своему исходному подразделу, удалил только что созданный лист, а затем снова повторил этот процесс, пока не учёл весь исходный лист.

Так, например, 140 тыс. строк будут выполнять первые 60 тыс. строк на исходном листе, следующие 60 тыс. — на новом листе, а последние 20 тыс. — на другом новом листе.

На самом деле ключевой момент заключался в том, чтобы поместить набор записей в новую подпрограмму и вызвать ее, и это было необходимо только потому, что ADO не видел вновь созданные листы, не выходя из исходной подпрограммы.

Спасибо за все входные данные, и вот мой код ниже, если вы заинтересованы. Обратите внимание, что код будет похож (с некоторыми изменениями) на чистую версию, опубликованную Xabier.

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

Вам не нужно разбивать запросы, потому что у вас более 60 000 строк... есть обходной путь.

См. здесь: https://stackoverflow.com/a/51402496/1274820

Вместо ссылки на диапазон просто укажите ссылку на лист.

Это относится и к именованным диапазонам (что не удастся).

Например, если ваши данные находятся в диапазоне Sheet1 A1:N152679, просто используйте SELECT SomeData FROM [Sheet1$] — ограничений нет.

Вместо того, чтобы прибегать к странному разделению ваших данных и запросов, временно поместите их на другой лист, если это необходимо.

Таким образом Excel может обрабатывать до 1,048,576 строк.