Question

我正像我已经做过很多次一样，尝试在excel工作表上执行查询，但是现在数据已超过7万行。通常，如果出现这种情况，我会收到消息无法找到表，这是可以预期的，因为我认为它在大约65k行左右停止工作。

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

对于我的特定示例，表为“ Sheet1 $ A1：N12790”，其中12790是70k以上行工作表中剩余的行数，Sheet1是运行代码时创建的工作表。

所以，我绝对不知道为什么通常在行太多或表绝对不存在时才会给出此错误。

我尝试运行带有单独子项的简单Select * from [Sheet1$A1:N12790]，并且效果很好。这使我相信，在执行第一个后，excel可能会以某种方式耗尽内存？但是我不知道该怎么做，并且网络上很少有信息，因为它是如此的具体和稀有，因为大多数人此时只使用常规数据库。

谢谢！

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

更新2：谢谢您到目前为止的所有想法和建议（6/20/18）。这是错误第二次运行并尝试运行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

Answer 1

我相信您的代码存在很多问题，但这不一定能解决您的问题，但是我试图整理您的代码并删除所有的Select＆Activate语句，因为它们并不是真正需要的，并且会激活其他工作表等时，有时会导致错误。

请查看下面的代码，希望您能得到一些指导：

$ grep --version
grep (GNU grep) 2.27

Answer 2

Excel认为您的记录集为空。

这不是内存错误。

具有8万行，您的代码进入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"

代码在第一次迭代中正确运行，在第二次迭代中，您会得到空警告。

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

Answer 3

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

Xabier用于更干净的代码。艾伦（Alan）用于识别根本问题。

问题是，当原始表拆分到新工作表上以解决多余的行时，即使该工作表存在，ADO也无法识别它。直到您离开当前的子程序，它才能识别出它（至少这是我从所有讨论，测试以及最终我的解决方案中得出的理解）。

因此，作为高级摘要：

要解决太多行并得到“访问无法找到表”错误消息，我将让前60k在当前工作表上运行，然后将下一个60k（或更少）复制到新工作表上
为了使ADO能够识别新创建的工作表，我将连接和记录集功能放在单独的子目录中，并通过传递我需要它成功运行所需的任何参数从原始子目录中调用它
然后，我回到原始子目录，删除了新创建的工作表，然后再次循环执行此过程，直到我占了整个原始工作表为止。

例如，如果有140k行将在原始工作表上运行前60k，从新工作表运行接下来的60k，然后从另一新工作表运行最后20k。

真正的关键是将记录集放入新的子目录中并调用它，这仅是必需的，因为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

Excel VBA ADO查询循环有太多行

3 个答案: