如何使用excel VBA運行訪問查詢？

Question

我是Access的新手，我一直嘗試運行Access查詢並使用VBA將結果粘貼到Excel中。 我已經結合了一些我找到的代碼，我想我幾乎已經擁有了它，但無法弄清楚最后一步。 這是代碼：

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

我正在嘗試運行查詢並將結果粘貼到工作表1中的單元格A1中。

我得到一行“運行時錯誤3219”：

Set rs = A.CurrentDb().QueryDefs("query name").OpenRecordset()

任何幫助將不勝感激。

謝謝，

G

Answer 1

我調整了您的代碼以從Access查詢中獲取數據，而無需創建完整的Access.Application實例。 在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

我會使用ADODB記錄集。 請嘗試以下代碼。 這里我連接到一個excel工作簿，但你可以使用相同的邏輯訪問數據庫，你只需要更改連接字符串。

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