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

Question

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

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?

@Mitch, when is it appropriate to upvote? If I select an answer does that accomplish the same thing? — sigil
– sigil, Commented Aug 18, 2011 at 1:01
Recordsets have a filter property, so you can create a new recordset that is a filtered version of an existing recordset. — David-W-Fenton
– David-W-Fenton, Commented Aug 19, 2011 at 23:37

David-W-Fenton · Accepted Answer · 2011-08-22 00:37:32Z

2

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.

answered Aug 22, 2011 at 0:37

David-W-Fenton

23.2k4 gold badges48 silver badges59 bronze badges

Sign up to request clarification or add additional context in comments.

1 Comment

sigil Over a year ago

Interesting; I didn't know about the .Filter property. I'll have to check this out and see if it's faster than what I came up with.

Lance Roberts · Accepted Answer · 2011-08-18 00:50:02Z

1

Use the .getrows method:

Dim rs_clone As Variant

...

rs_clone = rs.getrows(numrows)

then process the resulting 2-d array.

answered Aug 18, 2011 at 0:50

Lance Roberts

22.9k32 gold badges115 silver badges132 bronze badges

Comments

user1934049 · Accepted Answer · 2014-02-21 05:42:33Z

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

Collectives™ on Stack Overflow

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

3 Answers 3

1 Comment

Comments

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

1 Comment

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related