将数据从访问导入到打开的Excel电子表格中？ （Excel VBA）

Question

我正在尝试创建一个具有将数据从访问导入到Excel的功能的应用程序。在我让用户控制哪个表之前，我从一个名为“”1301 Array“”的表开始。问题是我得到错误“无法修改表结构。另一个用户有表打开”，假设是因为我正在写入Excel表。是否有工作要使用TransferSpreadsheet？

Sub Importfromaccess() 
Dim accappl As Access.Application 
Dim strpathdb As String 
Dim strpathxls As String 

strpathdb = Application.GetOpenFilename("Access DataBase (*.accdb),*.accdb") 

strpathxls = ActiveWorkbook.FullName 

Set accappl = New Access.Application 

accappl.OpenCurrentDatabase strpathdb 
Dim Page As Worksheet 
Dim lRow As Long, LCol As Long 
Dim fullrange As String 
Dim PageName As Variant 

accappl.DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "1301 Array", strpathxls, True 

accappl.Quit 

End Sub 

我发现网上大多使用SQL的解决方案，但我不知道如何在写，或者他们是如何得到SQL在Excel VBA中工作。下面的解决方案似乎做了类似于我需要的东西，但我不确定如何调整将表导入到新工作表中并为其指定相同的名称。

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

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



     Application.ScreenUpdating = False 

     Set TargetRange = Sheets("Sheet1").Range("A1") '1301 Array after creating it? 

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

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

      ' 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 


End Sub 

更新：我要去尝试使用这种方法

Sub AccessToExcel() 

'Declare variables. 
Dim dbConnection As ADODB.Connection 
Dim dbRecordset As ADODB.Recordset 
Dim dbFileName As String 
Dim strSQL As String 
Dim DestinationSheet As Worksheet 
'Set the assignments to the Object variables. 
Set dbConnection = New ADODB.Connection 
Set dbRecordset = New ADODB.Recordset 
Set DestinationSheet = Worksheets("Sheet2") 

'Define the Access database path and name. 
dbFileName = "C:\YourFilePath\Database1.accdb" 
'Define the Provider for post-2007 database files. 
dbConnection.Provider = "Microsoft.ACE.OLEDB.12.0;Data Source=" _ 
& dbFileName & ";Persist Security Info=False;" 

'Use SQL's SELECT and FROM statements for importing Table1. 
strSQL = "SELECT Table1.* FROM Table1;" 

'Clear the destination worksheet. 
DestinationSheet.Cells.Clear 

With dbConnection 
'Open the connection. 
.Open 
'The purpose of this line is to disconnect the recordset. 
.CursorLocation = adUseClient 
End With 

With dbRecordset 
'Create the recordset. 
.Open strSQL, dbConnection 
'Disconnect the recordset. 
Set .ActiveConnection = Nothing 
End With 

'Copy the Table1 recordset to Sheet2 starting in cell A2. 
'Row 1 contains headers that will be populated at the next step. 
DestinationSheet.Range("A2").CopyFromRecordset dbRecordset 

'Reinstate field headers (assumes a 4-column table). 
'Note that the ID field will also transfer into column A, 
'so you can optionally delete column A. 
DestinationSheet.Range("A1:E1").Value = _ 
Array("ID", "Header1", "Header2", "Header3", "Header4") 

'Close the recordset. 
dbRecordset.Close 
'Close the connection. 
dbConnection.Close 

'Release Object variable memory. 
Set dbRecordset = Nothing 
Set dbConnection = Nothing 
Set DestinationSheet = Nothing 

End Sub 

Answer 1

第一个版本将无法正常工作，因为你正在试图写入到你当前打开的Excel文件。

更改为以下行（第2码）将数据复制到另一个工作表：

Set TargetRange = Sheets("WhateverName").Range("A1") 'or 
Set TargetRange = Sheets(2).Range("A1") 
'..if you know it is the 2nd sheet that 
'you want to copy to. Then, 

Worksheets(2).Name = "1301 Array" 

你可以，或者，创建一个新的工作表：

Dim wsData As Worksheet 

Set wsData = Worksheets.Add 
wsData.Name = "1301 Array" 
Set TargetRange = wsData.Range("A1")