通过VBA从Access导入到特定的Excel工作表

Question

我试图弄清楚如何从Access表中获取我要导入Excel的数据以导入到特定工作表（可以是名为Sheet 2或Access Data的工作表）。我有以下代码来获取数据并在导入后以我想要的方式格式化它，但我无法将其导入到特定工作表中。我可以得到帮助吗？这就是我所拥有的：

使用分辨率更新代码：

Sub getAccessData()

Dim DBFullName As String
Dim Connect As String, Source As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim Col As Integer
Dim lngLastColumn As Long
Dim lngLastRow As Long
Dim OXLSheet As Worksheet

Set OXLSheet = Worksheets("WorksheetName")

Worksheets("WorksheetName").Cells.Clear

'Datebase path info
DBFullName = "C:\Users\myname\Desktop\Database Backups\database.accdb"

'Open the connection for the database
Set Connection = New ADODB.Connection
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;"
Connect = Connect & "Data Source=" & DBFullName & ";"
Connection.Open ConnectionString:=Connect


'Create RecordSet
Set Recordset = New ADODB.Recordset
With Recordset

    'Data Filter
    Source = "SELECT * FROM tblRetirements WHERE [AllowEnteredInPayroll] Is Null AND ApplicationCancelled = 'No'"
    .Open Source:=Source, ActiveConnection:=Connection


    'Write field Names
    For Col = 0 To Recordset.Fields.Count - 1
        Worksheets("WorksheetName").Range("A5").Offset(0, Col).Value = Recordset.Fields(Col).Name
    Next

    'Write Recordset
    Worksheets("WorksheetName").Range("A5").Offset(1, 0).CopyFromRecordset Recordset
End With
ActiveSheet.Columns.AutoFit
Set Recordset = Nothing
Connection.Close
Set Connection = Nothing



With OXLSheet
    lngLastColumn = .Cells(5, .Columns.Count).End(xlToLeft).Column
    lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    .ListObjects.Add(xlSrcRange, .Range(.Cells(5, 1), .Cells(lngLastRow, lngLastColumn)), , xlYes).Name = "Table1"

    ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleMedium16"
End With

End Sub

谢谢。

Answer 1

有一个错字，SELECT*FROM，应该是SELECT * FROM。

如果要导入特定工作表，请命名output，请尝试替换：

1. Range("A5").Offset(0, Col).Value = Recordset.Fields(Col).Name与Worksheets("output").Range("A5").Offset(0, Col).Value = Recordset.Fields(Col).Name
2. Range("A5").Offset(1, 0).CopyFromRecordset Recordset与Worksheets("output").Range("A5").Offset(1, 0).CopyFromRecordset Recordset

Answer 2

如果要在特定工作表中复制数据，例如名为Sheet2

' Declare a worksheet object
Dim objSheet As Worksheet

' initialize it
Set objSheet = ActiveWorkbook.Sheets("Sheet2")

'Write field Names
For Col = 0 To Recordset.Fields.Count - 1
    objSheet.Range("A5").Offset(0, Col).Value = Recordset.Fields(Col).Name
Next

'Write Recordset
objSheet.Range("A5").Offset(1, 0).CopyFromRecordset Recordset

Answer 3

以下是从一个文件夹中的所有EXCEL文件（工作表名称在所有文件中都相同）中的特定工作表中导入数据的通用代码。具有相同工作表名称的所有EXCEL文件的工作表必须具有相同布局和格式的数据。

Sub TryThis()

Dim strPathFile As String, strFile As String, strPath As String
Dim blnHasFieldNames As Boolean
Dim intWorksheets As Integer

' Replace 3 with the number of worksheets to be imported
' from each EXCEL file
Dim strWorksheets(1 To 3) As String

' Replace 3 with the number of worksheets to be imported
' from each EXCEL file (this code assumes that each worksheet
' with the same name is being imported into a separate table
' for that specific worksheet name)
Dim strTables(1 To 3) As String

' Replace generic worksheet names with the real worksheet names;
' add / delete code lines so that there is one code line for
' each worksheet that is to be imported from each workbook file
strWorksheets(1) = "GenericWorksheetName1"
strWorksheets(2) = "GenericWorksheetName2"
strWorksheets(3) = "GenericWorksheetName3"

' Replace generic table names with the real table names;
' add / delete code lines so that there is one code line for
' each worksheet that is to be imported from each workbook file
strTables(1) = "GenericTableName1"
strTables(2) = "GenericTableName2"
strTables(3) = "GenericTableName3"

' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = False

' Replace C:\Documents\ with the real path to the folder that
' contains the EXCEL files
strPath = "C:\Documents\"

' Replace 3 with the number of worksheets to be imported
' from each EXCEL file
For intWorksheets = 1 To 3

      strFile = Dir(strPath & "*.xls")
      Do While Len(strFile) > 0
            strPathFile = strPath & strFile
            DoCmd.TransferSpreadsheet acImport, _
                  acSpreadsheetTypeExcel9, strTables(intWorksheets), _
                  strPathFile, blnHasFieldNames, _
                  strWorksheets(intWorksheets) & "$"
            strFile = Dir()
      Loop

Next intWorksheets

End Sub