VBA 导入多个工作表

Question

我知道有很多不同的主题可以涵盖这个问题，但没有什么对我有用...我有 .xls 工作簿，其中包含 3 个工作表（Sheet1、Sheet2 和 Sheet3）。

每个工作表将有 65536 行（Sheet3 目前将有 25+ 行）。我在下面的链接上找到了一个代码，它应该可以完成这项工作......但是......它没有。它只会导入 25k 行。此外，只有 Sheet1 会有标题，Row1 上的 Sheet2 和 Sheet3 会有数据。

Import Data from All Worksheets in a single EXCEL File into One Table via TransferSpreadsheet (VBA)

我的 VBA 只从第一个选项卡导入 Excel 文件。有没有办法修改它，以便导入所有三个工作表，其中只有第一个有标题？

    Private Sub cmdButton_Click()

Dim strPathFile As String, strFile As String, strPath As String
Dim strTable As String
Dim blnHasFieldNames As Boolean

blnHasFieldNames = True
strPath = "C:\Folder\"
strTable = "dbo_tblTest"
strFile = Dir(strPath & "*.xlsx")

If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
If Dir(strPath & "*.*") = "" Then
MsgBox "The folder doesn't contain (visible) files"
Else

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Once purged LOOP file import
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Do While Len(strFile) > 0
strPathFile = strPath & strFile
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
        strTable, strPathFile, blnHasFieldNames


     strFile = Dir()
Loop

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' LOOP TO MOVE FILES IN ARCHIVE FOLDER
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Dim fso As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim FileExt As String

    FromPath = "S:\Folder"  '~~> Change
    ToPath = "S:\Folder\Archive"    '~~> Change
    FileExt = "*"

    '~~> You can use *.* for all files or *.doc for word files

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If
    Set fso = CreateObject("scripting.filesystemobject")
    If fso.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If
    If fso.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If
    fso.CopyFile Source:=FromPath & FileExt, Destination:=ToPath

    Kill "S:\Folder\*"
    MsgBox "Files Successfully Imported"

End If

End Sub

Answer 1

为了阅读工作簿中的所有工作表，您需要在传输电子表格命令中再添加一个参数（“范围”参数），并使用工作表名称对其进行完全限定：

'Put these with the rest of your variable declarations

 Dim objExcel As Object
 Dim wb As Object
 Dim ws As Object
 Dim strUsedRange As String

'Replace the current loop with the code starting from here

 Set objExcel = CreateObject("Excel.Application")

 Do While Len(strFile) > 0

     strPathFile = strPath & strFile
     Set wb = objExcel.Workbooks.Open(strPathFile)

     For Each ws In wb.Worksheets()
         'Loop over all the sheets in the workbook

          strUsedRange = ws.UsedRange.Address(0,0)
          DoCmdTransferSpreadsheet acImport, acSpreadsheetTypeExcel9, strTable, strPathFile, blnHasFieldNames, ws.Name & "!" & strUsedRange
     Next ws

     wb.Close
     Set wb = Nothing

     strFile = Dir()

 Loop

 Set objExcel = Nothing

这样做的好处是，它将使用 Excel 的内置 Worksheets 集合自动处理工作表名称和工作表中使用的范围，循环只是对其进行迭代。

Answer 2

我怀疑这就是你想要的。

Option Compare Database

Private Sub Command0_Click()

Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
Dim lngCount As Long
Dim objExcel As Object, objWorkbook As Object
Dim colWorksheets As Collection
Dim strPathFile As String, strTable As String
Dim strPassword As String

' Establish an EXCEL application object
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
      Set objExcel = CreateObject("Excel.Application")
      blnEXCEL = True
End If
Err.Clear
On Error GoTo 0


' Replace C:\Filename.xls with the actual path and filename
strPathFile = "your_path_here\testit.xls"

' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "tablename"


blnReadOnly = True ' open EXCEL file in read-only mode

' Open the EXCEL file and read the worksheet names into a collection
Set colWorksheets = New Collection
Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly)
For lngCount = 1 To objWorkbook.Worksheets.Count
      colWorksheets.Add objWorkbook.Worksheets(lngCount).Name

    ' Import the data from each worksheet into the table
    If lngCount = 1 Then
          DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
          strTable, strPathFile, False, colWorksheets(lngCount) & "$"
    Else
          DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
          strTable, strPathFile, False, colWorksheets(lngCount) & "$"
    End If

Next lngCount

' Close the EXCEL file without saving the file, and clean up the EXCEL objects
objWorkbook.Close False
Set objWorkbook = Nothing
If blnEXCEL = True Then objExcel.Quit
Set objExcel = Nothing

' Delete the collection
Set colWorksheets = Nothing

End Sub