CODEWITHSUNDEEP
vbaexcelms-access-2010
ColdTeck
ColdTeck

Reputation: 143

Pulling Information from Access into Excel

So currently I have code to pull a whole entire table worth of information from Access into Excel using Excel VBA. Is there a way that I can run a query in Excel VBA for Access and then just Pull they Query Data Across?

My Code for Pulling across as of now:

    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

Upvotes: 0

Views: 2083

Answers (1)

jacouh
jacouh

Reputation: 8741

Here is the solution by opening an Access query and import data to the 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

You call the last function in any Excel Macro using:

daoDoQueryCopyRecordsetNoParams

!!!Be carefull, the current Datasheet will be erased by the new data.

Upvotes: 1

Related Questions