vba - 从 Access 中提取信息到 Excel

Question

所以目前我有代码可以使用 Excel VBA 将整个表格的信息从 Access 中提取到 Excel 中。有没有一种方法可以让我在 Excel VBA 中为 Access 运行查询，然后将它们拉出查询数据？

到目前为止，我的拉动代码：

    Sheets(q).Select
    tablename = Sheets(q).Name
    Set cnt = New ADODB.Connection
    dbPath = "\FIMS_CDFT_Database.mdb"
    sPath = ActiveWorkbook.Path
    dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & sPath & dbPath & ";"
    With cnt
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open dbConnectStr
    End With
    sCmndString = "SELECT * FROM " & tablename
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open sCmndString, cnt, 2, 3, 1

     'transfer data to Excel
    Range("A4").CopyFromRecordset rs

Answer 1

这是通过打开 Access 查询并将数据导入 ActiveSheet 的解决方案：

'
' inputs:
'   strDbName: database filename
'   strQry: query name
'   strDataSheet: destination DataSheet name, to be erased with newdata
'
Function daoDoQueryCopyRecordset(ByVal strDbName, ByVal strQry, _
  ByVal strDataSheet)
'
  Dim objApp, qdf
  Dim rst As DAO.Recordset
'
  Set objApp = CreateObject("Access.Application")
'
  objApp.OpenCurrentDatabase strDbName
'
' get Recordset:
'
  Set qdf = objApp.CurrentDb.QueryDefs(strQry)
  Set rst = qdf.OpenRecordset(dbOpenDynaset)
'
  If (rst.EOF) Then
    Set rst = Nothing
    Set qdf = Nothing
    objApp.Quit
    Set objApp = Nothing
    daoDoQueryCopyRecordset = 0
    Exit Function
  End If
'
' create a new Excel Workbook to write results:
'
  Application.ScreenUpdating = False
'
' Workbooks.Add
'
' transfer data to Excel:
'
  ActiveWorkbook.Sheets(strDataSheet).Select
'
  ActiveSheet.Range("A4").CopyFromRecordset rst
'
  Application.ScreenUpdating = True
'
  rst.Close
  Set rst = Nothing
  Set qdf = Nothing
  objApp.Quit
  Set objApp = Nothing
'
  daoDoQueryCopyRecordset = 1
'
End Function


Function daoDoQueryCopyRecordsetNoParams()
'
  Dim strDbName, strQry, strDataSheet
'
  strDbName = ActiveWorkbook.Path & "\FIMS_CDFT_Database.mdb"
  strDataSheet = ActiveSheet.Name
  strQry = strDataSheet
'
  daoDoQueryCopyRecordsetNoParams = _
    daoDoQueryCopyRecordset(strDbName, strQry, strDataSheet)
'
End Function

您可以使用以下方法调用任何 Excel 宏中的最后一个函数：

daoDoQueryCopyRecordsetNoParams

!!!小心，当前数据表将被新数据擦除。