编写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