將數據從訪問導入到打開的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")