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

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

'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的内置工作表集合自动处理工作表中的工作表名称和使用范围，循环只是迭代过来。

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

VBA导入多个工作表

2 个答案: