sql - Excel VBA ADO查询循环太多行

Question

我正在尝试像我做过很多次一样在 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

标签： sqlvbaexcelms-jet-ace

Answer 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