ms-access - 编写 Excel VBA 以从 Access 接收数据

Question

我正在编写一个 Excel 应用程序，该应用程序从 Access 数据库中提取数据以进行工作。当用户打开 Excel 工具时，数据表需要填充我创建的 Access 数据库中的工作表之一。我一直在 Excel 中编写 VBA 代码，但收到运行时错误:“429”ActiveX 组件无法创建对象。

其他问题都是从 Access 编写的，但我相信我需要从 Excel 工作簿文件编写的代码。我编写的代码位于 Workbook_Open() 函数中，以便在用户打开文件时立即收集数据。非常感谢您的帮助。顺便说一句，我使用的是 Access 2007 和 Excel 2010。

Private Sub Workbook_Open()
    'Will fill the first listbox with data from the Access database
    Dim DBFullName As String
    Dim TableName As String
    Dim FieldName As String
    Dim TargetRande As String

    DBFullName = "D:\Tool_Database\Tool_Database.mdb"

    Dim db As DAO.Database, rs As Recordset
    Dim intColIndex As Integer

    Set TargetRange = Range("A1")
    Set db = OpenDatabase(DBFullName)
    Set rs = db.OpenRecordset("SELECT * FROM ToolNames WHERE Item = 'Tool'", dbReadOnly)

    ' Write the field names
    For intColIndex = 0 To rs.Fields.Count - 1
        TargetRange.Offset(1, intColIndex).Value = rs.Fields(intColIndex).Name
    Next

    ' Write recordset
    TargetRange.Offset(1, 0).CopyFromRecordset rs

    Set rs = Nothing
    db.Close
    Set db = Nothing
End Sub

Answer 1

泰勒，你能帮我测试一下这段代码吗？如果出现任何错误，您将收到一个消息框。只需发布消息框的快照即可。

'~~> Remove all references as the below code uses Late Binding with ADO.

Private Sub Workbook_Open()
          Dim cn As Object, rs As Object
          Dim intColIndex As Integer
          Dim DBFullName As String
          Dim TargetRange As Range

10        DBFullName = "D:\Tool_Database\Tool_Database.mdb"

20        On Error GoTo Whoa

30        Application.ScreenUpdating = False

40        Set TargetRange = Sheets("Sheet1").Range("A1")

50        Set cn = CreateObject("ADODB.Connection")
60        cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & DBFullName & ";"

70        Set rs = CreateObject("ADODB.Recordset")
80        rs.Open "SELECT * FROM ToolNames WHERE Item = 'Tool'", cn, , , adCmdText

          ' Write the field names
90        For intColIndex = 0 To rs.Fields.Count - 1
100           TargetRange.Offset(1, intColIndex).Value = rs.Fields(intColIndex).Name
110       Next

          ' Write recordset
120       TargetRange.Offset(1, 0).CopyFromRecordset rs

LetsContinue:
130       Application.ScreenUpdating = True
140       On Error Resume Next
150       rs.Close
160       Set rs = Nothing
170       cn.Close
180       Set cn = Nothing
190       On Error GoTo 0
200       Exit Sub
Whoa:
210       MsgBox "Error Description :" & Err.Description & vbCrLf & _
             "Error at line     :" & Erl & vbCrLf & _
             "Error Number      :" & Err.Number
220       Resume LetsContinue
End Sub