How do I copy and filter a DAO recordset in VBA?

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.

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

B开发者_如何学JAVAut 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?

In Access with DAO, this is how you'd do it:

  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.

Use the .getrows method:

Dim rs_clone As Variant

...

rs_clone = rs.getrows(numrows)

then process the resulting 2-d array.

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