如何在 VBA 中复制和过滤 DAO 记录集？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/7101127/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How do I copy and filter a DAO recordset in VBA?
提问by sigil
Due to problems with DAO (see my previous question), I need to create an Excel VBA Recordset from an Access query and filter its results using a user-defined function.
由于 DAO 的问题（请参阅我之前的问题），我需要从 Access 查询创建 Excel VBA 记录集并使用用户定义的函数过滤其结果。
I thought I could use the following code to accomplish this:
我以为我可以使用以下代码来完成此操作：
Sub test()
Dim db As Database
Dim rs As Recordset
Dim rs_clone As Recordset
Set db = OpenDatabase(dbPath)
Set rs = db.OpenRecordset("select testVal from dataTable")
Set rs_clone = rs.Clone
rs_clone.MoveLast
rs_clone.MoveFirst
while not rs_clone.eof
if myUDF(rs_clone!testVal) then
rs_clone.delete
end if
rs_clone.moveNext
wend
End Sub
But that actually deletes values from my source table, so the clone isn't a new recordset that I can freely alter, it's just another pointer to the original one. How can I use my UDF to filter out the records I don't want, while leaving the original data untouched, if putting the UDF in the query itself is not an option?
但这实际上会从我的源表中删除值，因此克隆不是我可以自由更改的新记录集，它只是另一个指向原始记录集的指针。如果将 UDF 放入查询本身不是一种选择，我如何使用我的 UDF 过滤掉我不想要的记录，同时保持原始数据不变？
采纳答案by Lance Roberts
Use the .getrows method:
使用 .getrows 方法：
Dim rs_clone As Variant
...
rs_clone = rs.getrows(numrows)
then process the resulting 2-d array.
然后处理生成的二维数组。
回答by David-W-Fenton
In Access with DAO, this is how you'd do it:
在 Access with DAO 中，您可以这样做：
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsFiltered As DAO.Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT tblInventory.* FROM tblInventory;")
rs.MoveLast
Debug.Print "Unfiltered: " & rs.RecordCount
rs.filter = "[LastUpdated]>=#1/1/2011#"
Set rsFiltered = rs.OpenRecordset
rsFiltered.MoveLast
Debug.Print "Filtered: " & rsFiltered.RecordCount
rsFiltered.Close
Set rsFiltered = Nothing
rs.Close
Set rs = Nothing
Set db = Nothing
However, note that (as mentioned in the help file), it may be just as fast to simply reopen the recordset with new criteria, instead of filtering the existing recordset.
但是，请注意（如帮助文件中所述），使用新条件重新打开记录集而不是过滤现有记录集可能同样快。
回答by user1934049
Option Compare Database
Private Sub Command0_Click()
Sub Export_Click()
Dim db As Database, rs As Recordset, sql As String, r As Variant
Dim appExcel As Excel.Application
Dim excelWbk As Excel.Workbook
Dim excelSht As Object
Dim rng As Excel.Range
Set appExcel = New Excel.Application
On Error Resume Next
Set excelWbk = appExcel.Workbooks.Open("Folder Name(Template)")
Set db = CurrentDb()
sql1 = "Select * from Query_New"
sql2 = "Select * from Query_Expired"
Set rs1 = db.OpenRecordset(sql1, dbReadOnly)
Set rs2 = db.OpenRecordset(sql2, dbReadOnly)
Dim SheetName1 As String
Dim SheetName2 As String
SheetName1 = "New"
SheetName2 = "Expired"
'For first sheet
On Error Resume Next
excelWbk.Sheets(SheetName1).Select
If Err.Number <> 0 Then
MsgBox Err.Number
excelWbk.Close False
appExcel.Quit
Exit Sub
End If
With excelWbk.Activesheet
.Cells(5, 1).CopyFromRecordset rs1
On Error GoTo 0
End With
'For second sheet
On Error Resume Next
excelWbk.Sheets(SheetName2).Select
If Err.Number <> 0 Then
MsgBox Err.Number
excelWbk.Close False
appExcel.Quit
Exit Sub
End If
With excelWbk.Activesheet
.Cells(5, 1).CopyFromRecordset rs2
On Error GoTo 0
End With
rs1.Close
Set rs1 = Nothing
rs2.Close
Set rs2 = Nothing
db.Close
Set db = Nothing
On Error Resume Next
excelWbk.SaveAs "C:\Documents and settings\" & Environ("UserName") & "\Desktop\Decision.xlsx"
If Err.Number <> 0 Then
MsgBox Err.Number
End If
excelWbk.Close False
appExcel.Quit
Set appExcel = Nothing
MsgBox "The report has been saved"
End Sub
End Sub
