How to run access query using excel VBA? - vba

Question

I am fairly new to Access and I have been trying for a while to run an Access query and paste the results in Excel using VBA. I have combined some code I found and I think I almost have it but cannot figure out the last step. Here is the code:
Sub test()
Dim ws As Worksheet
Dim A As Object
Dim rs As Object
Application.DisplayAlerts = False
Set A = CreateObject("Access.Application")
Set ws = ThisWorkbook.Sheets("Sheet1")
A.Visible = True
A.OpenCurrentDatabase ("access database path")
A.DoCmd.OpenQuery ("query name")
Set rs = A.CurrentDb().QueryDefs("query name").OpenRecordset()
If Not rs.EOF Then
ws.Range("A1").CopyFromRecordset rs
End If
rs.Close
Application.DisplayAlerts = True
End Sub
I am trying to run the query and paste the results in cell A1 in sheet 1.
I get a "run time error 3219" for the line:
Set rs = A.CurrentDb().QueryDefs("query name").OpenRecordset()
Any help would be greatly appreciated.
Thanks,
G

Answer 1

I adapted your code to fetch data from an Access query without needing to create a full Access.Application instance. Tested and working in Excel 2010.
Const cstrPath As String = "C:\share\Access\Database2.accdb"
Const cstrQuery As String = "qryBase"
Dim dbe As Object 'DAO.DBEngine '
Dim rs As Object 'DAO.Recordset '
Dim ws As Worksheet
Application.DisplayAlerts = True 'leave alerts on during testing '
Set dbe = CreateObject("DAO.DBEngine.120")
Set rs = dbe.OpenDatabase(cstrPath).OpenRecordset(cstrQuery)
If Not rs.EOF Then
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Range("A1").CopyFromRecordset rs
End If
rs.Close
Application.DisplayAlerts = True

Answer 2

I would use ADODB recordset. Try the below code. Here I'm connecting to an excel workbook, but you can use the same logic for access database, you just need to change the connection string.
Private con As ADODB.Connection
Private ra As ADODB.Recordset
' SqlString = SQL Query
' Sht = Sheet Name, where the output needs to be displayed
' Rng = Range ("C5"), where the output needs to be displayed
Sub DoSql(SqlString As String, Sht As String, Rng As String, Optional IncludeHeading As Boolean = False)
Dim a As String
Dim res As Variant
Set con = New ADODB.Connection
Set ra = New ADODB.Recordset
res = ""
'a = Set the appropriate connection string for your database
'The below connection is referring to the same excel workbook which contains the macro
a = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=""" & ThisWorkbook.FullName & """;Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
'MsgBox a
'MsgBox SqlString
If Not Left("" & con, 8) = "Provider" Then
con.Open a
End If
If Not ra.State = 0 Then
ra.Close
End If
ra.Open SqlString, con
If Not (ra.EOF And ra.BOF) Then
ra.MoveFirst
Sheets(Sht).Select
If IncludeHeading = True Then
For intColIndex = 0 To ra.Fields.Count - 1
Range(Rng).Offset(0, intColIndex).Value = ra.Fields(intColIndex).Name
Next
Range(Rng).Offset(1, 0).CopyFromRecordset ra
Else
Range(Rng).CopyFromRecordset ra
End If
End If
ra.Close
con.Close
End Sub