Как мне скопировать и отфильтровать набор записей DAO в VBA? - PullRequest
Новая
       46

Как мне скопировать и отфильтровать набор записей DAO в VBA?

1 голос
/ 18 августа 2011

Из-за проблем с DAO (см. мой предыдущий вопрос ) мне нужно создать набор записей Excel VBA из запроса Access и отфильтровать его результаты с помощью пользовательской функции.

Я думал, что мог бы использовать следующий код для достижения этой цели: 

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 в сам запрос не вариант?

Ответы [ 3 ]

2 голосов
/ 22 августа 2011

В Access с 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

Тем не менее, обратите внимание, что (как указано в файле справки) может быть также просто быстро открыть набор записей с новыми критериями вместо фильтрации существующего набора записей.

1 голос
/ 18 августа 2011

Используйте метод .getrows: 

Dim rs_clone As Variant

...

rs_clone = rs.getrows(numrows)

, затем обработайте полученный 2-й массив.

0 голосов
/ 21 февраля 2014 
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
...