Excel VBA ADO 查询循环太多行
Excel VBA ADO query loop for too many rows
我正在尝试对 excel 工作sheet 执行查询，就像我做过很多次一样，但现在数据有超过 70k 行。通常，如果是这种情况，我会收到消息说它找不到 table，这是可以预料的，因为我认为它在大约 65k 行左右停止工作。
所以，我正在尝试的是做一个循环，在循环的第一部分我 运行 前 60k 行，并且在循环的每次迭代中它都会执行另一批 60k 直到它以最后一组结束。该循环使用要处理的数据创建一个新的 sheet，因此我可以将列 headers 与数据集一起使用。它似乎一直工作到 运行 对来自新 sheet 的数据进行新查询的部分。它给我的错误是 "The Microsoft Access database engine could not find the object " (My Table Name)... etc.
对于我的具体示例，table 是 "Sheet1$A1:N12790"，其中 12790 是超过 70k 行的剩余行数 sheet，Sheet1 是 sheet当您 运行 代码时创建。
所以，我完全不知道为什么它会给出这个错误，而它通常只在行太多或者 table 绝对不存在时才会出现。
我尝试了 运行 一个简单的 Select * from [Sheet1$A1:N12790] 和一个单独的 sub，它工作得很好。这让我相信，也许 excel 在执行第一个之后可能 运行 内存不足？但我不知道该怎么办，而且网上关于这方面的信息很少，因为它是如此具体和罕见，因为此时大多数人只使用常规数据库。
谢谢！
更新：我一直在测试很多东西。我已经尝试创建一个测试子来处理新的 sheet （如上所述）并且它在 运行 单独时工作，但是如果我尝试强制主子尽快退出循环然后调用new test sub to 运行 我想让它做什么，它给了我同样的错误。再说一次，两个 subs 运行 完全分开，但我不能用一个来调用另一个。向我展示了更多证据，证明它与编码无关，而与某种处理复杂性有关，但我仍然只是提出理论。
更新 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
我认为您的代码存在许多问题，这不一定是您问题的答案，但我已尝试整理您的代码并删除所有 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 认为您的记录集是空的。
不是内存错误。
对于 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"
代码第一次迭代运行正确，第二次迭代你得到空警告。
为什么不返回记录，我不能告诉你。但这是你的错误。
感谢 Xabier 和 Alan 对解决方案的贡献。
Xabier 用于更简洁的代码。
艾伦找出潜在的问题。
问题是，当原始 table 被拆分到新的 sheet 以解决多余的行时，即使 sheet 存在，ADO 也无法识别它然而。直到你离开当前的 sub，它才会识别它（至少这是我从所有讨论、测试和最终我的解决方案中的理解）。
因此，作为一个高级摘要：
为了解释太多行并得到 "Access cannot find your table" 错误消息，我会让前 60k 运行 在当前 sheet 上，然后复制接下来 60k（或更少）到新的 sheet.
为了让 ADO 识别新创建的 sheet，我将连接和记录集功能放入一个单独的 sub 中，并通过传递任何参数从我的原始 sub 中调用它我需要它才能 运行 成功。
然后我回到我原来的sub，删除了新创建的sheet，然后再次循环这个过程，直到我占了整个原始sheet。
因此，例如，140k 行将 运行 原始 sheet 的前 60k，运行 新 sheet 的下一个 60k，以及另一个新 sheet.
的最后 20k
真正的关键是将记录集放入一个新的 sub 中并调用它，这只是必要的，因为 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 行...有一个可用的解决方法。
看这里：
不引用范围，只引用 sheet。
这也适用于命名范围（这会失败）。
例如，如果您的数据在 Sheet1 范围内 A1:N152679，只需使用 SELECT SomeData FROM [Sheet1$] - 没有限制。
如果需要，与其费力地拆分数据和查询，不如将它们暂时放在另一个 sheet 上。
Excel 以这种方式最多可以处理 1,048,576 行。
我正在尝试对 excel 工作sheet 执行查询，就像我做过很多次一样，但现在数据有超过 70k 行。通常，如果是这种情况，我会收到消息说它找不到 table，这是可以预料的，因为我认为它在大约 65k 行左右停止工作。
所以，我正在尝试的是做一个循环，在循环的第一部分我 运行 前 60k 行，并且在循环的每次迭代中它都会执行另一批 60k 直到它以最后一组结束。该循环使用要处理的数据创建一个新的 sheet，因此我可以将列 headers 与数据集一起使用。它似乎一直工作到 运行 对来自新 sheet 的数据进行新查询的部分。它给我的错误是 "The Microsoft Access database engine could not find the object " (My Table Name)... etc.
对于我的具体示例，table 是 "Sheet1$A1:N12790"，其中 12790 是超过 70k 行的剩余行数 sheet，Sheet1 是 sheet当您 运行 代码时创建。
所以，我完全不知道为什么它会给出这个错误，而它通常只在行太多或者 table 绝对不存在时才会出现。
我尝试了 运行 一个简单的 Select * from [Sheet1$A1:N12790] 和一个单独的 sub，它工作得很好。这让我相信，也许 excel 在执行第一个之后可能 运行 内存不足？但我不知道该怎么办，而且网上关于这方面的信息很少，因为它是如此具体和罕见，因为此时大多数人只使用常规数据库。
谢谢！
更新：我一直在测试很多东西。我已经尝试创建一个测试子来处理新的 sheet （如上所述）并且它在 运行 单独时工作，但是如果我尝试强制主子尽快退出循环然后调用new test sub to 运行 我想让它做什么，它给了我同样的错误。再说一次，两个 subs 运行 完全分开，但我不能用一个来调用另一个。向我展示了更多证据，证明它与编码无关，而与某种处理复杂性有关，但我仍然只是提出理论。
更新 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
我认为您的代码存在许多问题，这不一定是您问题的答案，但我已尝试整理您的代码并删除所有 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 认为您的记录集是空的。
不是内存错误。
对于 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"
代码第一次迭代运行正确，第二次迭代你得到空警告。
为什么不返回记录，我不能告诉你。但这是你的错误。
感谢 Xabier 和 Alan 对解决方案的贡献。
Xabier 用于更简洁的代码。 艾伦找出潜在的问题。
问题是，当原始 table 被拆分到新的 sheet 以解决多余的行时，即使 sheet 存在，ADO 也无法识别它然而。直到你离开当前的 sub，它才会识别它（至少这是我从所有讨论、测试和最终我的解决方案中的理解）。
因此，作为一个高级摘要：
为了解释太多行并得到 "Access cannot find your table" 错误消息，我会让前 60k 运行 在当前 sheet 上，然后复制接下来 60k（或更少）到新的 sheet.
为了让 ADO 识别新创建的 sheet，我将连接和记录集功能放入一个单独的 sub 中，并通过传递任何参数从我的原始 sub 中调用它我需要它才能 运行 成功。
然后我回到我原来的sub，删除了新创建的sheet，然后再次循环这个过程，直到我占了整个原始sheet。
因此，例如，140k 行将 运行 原始 sheet 的前 60k，运行 新 sheet 的下一个 60k，以及另一个新 sheet.
的最后 20k真正的关键是将记录集放入一个新的 sub 中并调用它，这只是必要的，因为 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 行...有一个可用的解决方法。
看这里：
不引用范围，只引用 sheet。
这也适用于命名范围（这会失败）。
例如，如果您的数据在 Sheet1 范围内 A1:N152679，只需使用 SELECT SomeData FROM [Sheet1$] - 没有限制。
如果需要，与其费力地拆分数据和查询，不如将它们暂时放在另一个 sheet 上。
Excel 以这种方式最多可以处理 1,048,576 行。