通过 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