如何使用excel 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