excel - 使用 VBA 将 MS Access 数据库查询导入 Excel，无需登录提示

Question

我正在尝试将 MS Access 查询导入到 Excel 中而不触发登录提示。我尝试了几种不同的方法来执行此操作，但这两种方法都没有给我一个完整的解决方案。

具体:

1. 我的 Access 查询源是 MS Access 2010 中内置的不 protected Access 数据库文件 (database1.accdb)。该数据库从不同来源获取表(通过使用链接表)并执行数据处理。这些来源之一需要密码，因此当我运行查询时，会出现登录提示，要求我提供凭据(我已经拥有)。我对查询本身没有任何问题。

2. 我的 Excel 电子表格(内置于 Excel 2010)包含从其他数据源检索表的 VBA 代码，其中一些还需要身份验证，因此我构建了一个自定义提示，让用户输入所有表的凭据.

这里的问题是，我在 Excel 电子表格中出现一个提示，要求用户提供登录信息，但在导入 Access 查询时又出现另一个提示。以下是我尝试解决该问题的方法:

方法 1:使用宏录制器:

我使用 Excel 的内置宏记录器来按照我的手动步骤导入 Access 查询。当我录制宏时，导入有效，并且查询没有出现预期的错误。但是，当我尝试运行宏时，出现运行时错误:

"Run-time error '1004':

The query did not run, or the database could not be opened. Check the database  
server or contact your database administrator. Make sure the external database  
is available and has not been moved or reorganized, then try the operation  
again."

来自宏记录器的代码:

Sub Macro2()
    
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;" _
        , "Data Source=C:\Database1.accdb;Mode=Share Deny Write;" _
        , "Extended Properties="""";Jet OLEDB:System database="""";" _
        , "Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";" _
        , "Jet OLEDB:Engine Type=6;Jet OLEDB:Database Locking Mode=0;" _
        , "Jet OLEDB:Global Partial Bulk Ops=2;" _
        , "Jet OLEDB:Global Bulk Transactions=1;" _
        , "Jet OLEDB:New Database Password="""";" _
        , "Jet OLEDB:Create System Database=False;" _
        , "Jet OLEDB:Encrypt Database=False;" _
        , "Jet OLEDB:Don't Copy Locale on Compact=False;" _
        , "Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;" _
        , "Jet OLEDB:Support Complex Data=False;" _
        , "Jet OLEDB:Bypass UserInfo Validation=False"), _
        Destination:=Range("$A$4")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array("Query3")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = "C:\Database1.accdb"
        .ListObject.DisplayName = "Table_Database1"
        .Refresh BackgroundQuery:=False
    End With
    Range("I3").Select
   
End Sub

我猜测为什么这个宏不起作用(但手动步骤起作用)是因为记录器忽略了一些参数。如果我删除了某些密码字段中的引号，代码不会出错，但我会再次收到登录提示。我希望这里有人可以查看是否缺少参数或错误分配的参数。

方法2:使用DAO库:

对于这个方法，我必须做一些改变。首先，我必须在编辑器中添加“Microsoft DAO 3.6 对象库”的引用。然后我必须将 .accdb 文件转换为 .mdb 文件，以便我可以使用 DAO 函数:

DAO 方法代码:

Sub Macro3()

    Dim db1 As Database
    Dim db2 As Database
    Dim recSet As Recordset
    Dim strConnect As String
   
    Set db1 = OpenDatabase("C:\Database1.mdb")
    strConnect = db1.QueryDefs("Query3").Connect _
    & "DSN=myDsn;USERNAME=myID;PWD=myPassword"
   
    Set db2 = OpenDatabase("", False, False, strConnect)
    db2.Close
    Set db2 = Nothing
   
    Set recSet = db1.OpenRecordset("Query3")
   
    With ActiveSheet.QueryTables.Add(Connection:=recSet, Destination:=Range("$A$4"))
        .Name = "Connection"
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
 
    End With
   
    recSet.Close
    db1.Close
    Set recSet = Nothing
    Set db1 = Nothing
   
End Sub

此方法有效，我可以绕过数据库的登录提示...只要我的查询不返回大量记录。当我返回大约 60,000 条记录时，代码不会花费超过 5-10 秒的时间来获得结果。然而，当我尝试提取超过 100,000 条记录时，Excel 将变得无响应并挂起(我让代码运行了大约 10 分钟，然后才停止)。我想我已经遇到了 DAO 的一些限制，除了我找不到解决这个问题的文档之外。

感谢您的帮助。

Answer 1

试试这个:

Sub ShowData()


   Dim daoDB            As DAO.Database
   Dim daoQueryDef      As DAO.QueryDef
   Dim daoRcd           As DAO.Recordset

    Set daoDB = OpenDatabase("C:\Database1.mdb")  
    Set daoQueryDef = daoDB.QueryDefs("Query3")

    Set daoRcd = daoQueryDef.OpenRecordset
    ThisWorkbook.Worksheets("Sheet1").Range("A4").CopyFromRecordset daoRcd


End Sub

或者这个...在这种情况下，您需要在 VBA 窗口中编写完整的查询

Sub new1()

    Dim objAdoCon       As Object
    Dim objRcdSet       As Object

    Set objAdoCon = CreateObject("ADODB.Connection")
    Set objRcdSet = CreateObject("ADODB.Recordset")    


     objAdoCon.Open "Provider = Microsoft.Jet.oledb.4.0;Data Source = C:\Database1.mdb" 
     objRcdSet.Open "Write ur Query Here", objAdoCon

     ThisWorkbook.Worksheets("Sheet1").Range("A1").CopyFromRecordset objRcdSet

    Set objAdoCon = Nothing
    Set objRcdSet = Nothing

End Sub