Excel VBA ADO查询循环太多行

Posted 2023-04-19

技术标签:

【中文标题】Excel VBA ADO查询循环太多行【英文标题】：Excel VBA ADO query loop for too many rows 【发布时间】：2018-06-19 16:01:57 【问题描述】：

我正在尝试在 Excel 工作表上执行查询，就像我做过很多次一样，但现在数据有超过 70k 行。通常，如果是这种情况，我会收到消息说它找不到表，这是可以预料的，因为我认为它在大约 65k 行左右停止工作。

所以，我正在尝试做一个循环，在循环的第一部分我运行前 60k 行，并且在循环的每次迭代中，它会执行另一批 60k，直到它完成最后一组。该循环创建一个包含要处理的数据的新工作表，因此我可以将列标题与数据集一起使用。它似乎一直工作到它对新工作表中的数据运行新查询的部分。它给了我“Microsoft Access 数据库引擎找不到对象”（我的表名）...等错误。

对于我的具体示例，该表是“Sheet1$A1:N12790”，其中 12790 是超过 70k 行工作表的剩余行数，Sheet1 是运行代码时创建的工作表。

所以，我完全不知道为什么它会给出这个错误，而它通常只在行太多或表肯定不存在时才会出现。

我尝试使用单独的子程序运行一个简单的Select * from [Sheet1$A1:N12790]，它运行良好。这让我相信，也许在做第一个之后，excel可能内存不足？但我不知道该怎么做，而且网上关于这个的信息很少，因为它是如此具体和罕见，因为大多数人此时只是使用常规数据库。

谢谢！

更新：我一直在测试很多东西。我已经尝试创建一个测试子来处理新工作表（如上所述），它在单独运行时可以工作，但是如果我尝试强制主子尽快退出循环，然后调用新的测试子来运行我想要的这样做，它给了我同样的错误。再说一次，两个潜艇完美地分开运行，但我不能用一个来调用另一个。向我展示了更多证据表明它与编码无关，而更多地与某种处理复杂性有关，但我仍然只是提出理论。

更新 2：感谢您迄今为止（2018 年 6 月 20 日）提出的所有想法和建议。这是第二次运行并尝试运行 mysql 时出现的错误内容的屏幕截图：

错误信息：

如果有帮助，下面是我的代码：

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

【问题讨论】：

首先突出的是您将变量声明为整数，我很确定这些应该声明为 Long，因为整数不能保存大于 32k 左右的值... @Xabier 我明白你的意思，但是如果你仔细观察，你会发现设置为整数的变量并没有持有超大的值。事实上，那些被声明为 double 并且在我所有其他查询中似乎都做得很好的那些。就像我在上面的帖子中试图提到的那样，当工作表的行数少于 65k 左右时，这非常有效...... 为了避免XY Problem 和通过大量代码进行挖掘，请向我们提供输入和所需输出的数据样本的完整背景。另外，考虑使用一个实际的数据库。请注意：Excel is not a database。是的，您可以使用 MS Access（即它的引擎），尽管您可能已经安装了 .exe 程序（实际上只是引擎的 GUI 控制台）。所以你可以create and use Access databases。 VBA 肯定在代码模块中而不是代码工作表中？ 【参考方案1】：

我认为您的代码存在许多问题，这不一定是您问题的答案，但我已尝试整理您的代码并删除所有 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

【讨论】：

wsFanned 的重复定义。另外，认为MySheet2.UsedRange 是多余的，因为它紧随其后的是Set MyRange = MySheet2.UsedRange。否则，太棒了——应该怎么写！ @Alan，我现在已经更新它以反映您的 cmets，谢谢！我只是快速尝试向 OP 展示他们如何避免选择/激活。 :) @Xabier 感谢您花时间整理它。我是自学成才的，所以并不总是知道所有的技巧，所以看到另一种做事方式很有趣。在调整了一些小东西后，我对其进行了测试，它确实有效。不幸的是，它的工作方式与我的代码相同，并且仍然给出相同的结果。感谢您花时间和精力向我展示一些新想法。谢谢。 @RickW。在向我们展示了您遇到的错误后，我又更新了代码，不确定它是否会按预期工作，但值得一试，我猜... @Xabier 老实说，我不知道你改变了什么，但也许是因为你更新了一些我已经更新的东西......也许如果你澄清更新我会看到它.【参考方案2】：

Excel 认为您的记录集为空。

这不是内存错误。

如果有 80k 行，您的代码将进入 ElseIf (NewRowCount > 0) And (NewRowCount <= 60000) Then 块。当它尝试调用关联的记录集时，它会失败。

您可以通过更改这行代码来测试此行为：

MyRecordSet.Open MySQL, MyConn, adOpenKeyset, adLockOptimistic

到：

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

代码在第一次迭代时正确运行，第二次迭代你得到空警告。

为什么它不返回记录，我不能告诉你。但这是你的错误。

【讨论】：

嘿，这是个好主意。我尝试过并仔细考虑过，但我确实有几个问题。 1. 尝试运行MySQL时出现错误，说找不到我要从中拉取的表。因此，它不会返回任何内容，并且默认情况下 MyRecordset 将是空的，因为问题而不是问题的原因（如果我认为这是正确的）。因此，返回 null 的 msgbox 实际上并不能证明任何事情。 2.我可以在原始文件关闭后使用单独的子程序运行它，并且使用 MySQL 的相同字符串值来运行它，这一事实让我知道运行该 SQL 将在正常基础上产生结果。所以我可以让excel使用相同的MySQL创建记录集，只要它不使用相同的子:(我喜欢你有一个尝试的想法，感谢你花时间考虑一个，但我不认为它在这种情况下是有效的。我认为对于错误的外观可能存在一些误解。如果我截取错误会有所帮助吗？可能是因为找不到表。不仅如此，正如显示 sql 文本的 msgbox 所证明的那样，乍一看似乎还可以。测试 Recordset 是否为空的要点是错误跟踪的一部分，以找出错误是否在选择和粘贴、抓取记录集等方面。也许值得考虑换个方向？与其动态添加新工作表，不如创建多个结果保存工作表（例如 Results1 - Results10）。隐藏它们 - 隐藏或非常隐藏。理想情况下，也有固定的源表并将数据分成 60k 块。然后您可以对所有调用进行硬编码 - Source1 -> Results1 等。无需循环遍历结果，您只需访问每个使用的工作表的UsedRange（并且您可以在控制表中跟踪使用的工作表)。我测试了你所说的，我认为这是由于ADO没有识别它造成的。我通过强制它使用在运行之前存在的表来运行它，它完成了所需的操作。因此，我将尝试将其转化为类似于您所逃避的解决方案，一旦完成，我将在此处发布解决方案。谢谢艾伦！感谢您花时间帮助我解决这个问题。【参考方案3】：

感谢 Xabier 和 Alan 对解决方案的贡献。

Xabier 用于更简洁的代码。 Alan 指出了根本问题。

问题在于，当原始表被拆分到新工作表以解决多余的行时，即使工作表存在，ADO 也无法识别它。直到你离开当前的 sub，它才会识别它（至少这是我从所有讨论、测试和最终我的解决方案中的理解）。

所以，作为一个高级摘要：

然后我回到原来的 sub，删除了新创建的工作表，然后再次循环执行此过程，直到我计算完整个原始工作表。

因此，例如，140k 行将在原始工作表上运行前 60k 行，在新工作表上运行下一个 60k，在另一个新工作表上运行最后 20k。

真正的关键是将记录集放入一个新的 sub 并调用它，这只是必要的，因为 ADO 在没有先离开原始 sub 的情况下看不到新创建的工作表。

感谢所有输入，如果您有兴趣，下面是我的代码。请注意，代码看起来与 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

【讨论】：

【参考方案4】：

您不需要拆分查询，因为您有超过 60,000 行...有可用的解决方法。

请看这里：https://***.com/a/51402496/1274820

不引用范围，只引用工作表。

这也适用于命名范围（这将失败）。

例如，如果您的数据在Sheet1 范围A1:N152679 上，则只需使用SELECT SomeData FROM [Sheet1$] - 没有限制。

不要费力地拆分数据和查询，如果需要，可以暂时将它们放在另一张纸上。

Excel 以这种方式最多可以处理1,048,576 行。

【讨论】：

以上是关于Excel VBA ADO查询循环太多行的主要内容，如果未能解决你的问题，请参考以下文章

Excel vba 多个条件查询应该怎么做，可以用find方法吗？