Question

由于DAO问题（请参阅my previous question），我需要从Access查询创建Excel VBA Recordset并使用用户定义的函数过滤其结果。

我以为我可以使用以下代码来完成此任务：

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

但是这实际上是从我的源表中删除了值，因此克隆不是我可以自由改变的新记录集，它只是指向原始记录集的另一个指针。如果将UDF放入查询本身不是一个选项，我如何使用我的UDF过滤掉我不想要的记录，同时保持原始数据不变？

Answer 1

在使用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

但是，请注意（如帮助文件中所述），使用新条件简单地重新打开记录集可能同样快，而不是过滤现有记录集。

Answer 2

使用.getrows方法：

Dim rs_clone As Variant

...

rs_clone = rs.getrows(numrows)

然后处理生成的二维数组。

Answer 3

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

如何在VBA中复制和过滤DAO记录集？

3 个答案: