要使用 Excel 自动化执行此操作，首先定义以下函数，该函数使用here 概述的技术获取工作表中最后使用的单元格：
Function LastUsedCell(wks As Excel.Worksheet) As Excel.Range
With wks
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
Set LastUsedCell = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
End If
End With
End Function
还有这个辅助函数，用于确定从每个工作表中开始复制数据的位置：
Function GetNextRowStart(wks As Excel.Worksheet) As Excel.Range
Dim lastCell As Excel.Range
Dim nextRow As Integer
nextRow = 1
Set lastCell = LastUsedCell(wks)
If Not lastCell Is Nothing Then nextRow = lastCell.Row + 1
Set GetNextRowStart = wks.Cells(nextRow, 1)
End Function
那么就可以使用下面的代码了：
Dim outputWorkbook As Excel.Workbook
Dim outputWorksheet As Excel.Worksheet
Dim filepath As Variant
Set outputWorkbook = Workbooks.Open("D:\Zev\Clients\stackoverflow\outputMultipleWokrbooksWithADO\output.xlsx")
Set outputWorksheet = outputWorkbook.Sheets("Sheet1")
For Each filepath In Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
Dim wkbk As Excel.Workbook
Dim wks As Excel.Worksheet
Set wkbk = Workbooks.Open(filepath, , True)
For Each wks In wkbk.Sheets
Dim sourceRange As Excel.Range
Dim outputRange As Excel.Range
With wks
Set sourceRange = .Range(.Cells(1, 1), LastUsedCell(wks))
End With
Set outputRange = GetNextRowStart(outputWorksheet)
sourceRange.Copy outputRange
Next
Next
outputWorksheet.Columns.AutoFit
以前的方法使用 Excel 自动化 -- 打开工作簿，获取工作表，操作源工作表和输出工作表上的范围。在移动过程中，可以按原样复制数据或以某种方式转换数据。
您还可以使用 ADODB 来读取 Excel 工作表，就好像工作簿是一个数据库，工作表是它的表一样；然后发出INSERT INTO 语句将原始记录复制到输出工作簿中。它提供以下好处：
- 一般来说，通过 SQL 传输数据比通过自动化传输数据更快（打开工作簿、复制和粘贴范围）。
- 如果没有数据转换，另一种选择是读取
Range 对象的Value 属性，它返回一个二维数组。这可以很容易地分配/粘贴到任何需要这样一个数组的东西，包括 Value 属性本身。
- 使用 SQL 转换数据是声明式的——只需定义数据的新形式。相反，使用自动化转换数据意味着读取每一行并在每一行上运行一些代码。
- 更具声明性的选项可能是将 Excel 公式写入其中一列，然后复制并粘贴值。
但是，它存在以下限制：
- 这通过发出一条 SQL 语句来工作。如果您不熟悉 SQL，这可能对您没有用处。
- 只能使用支持 SQL 的函数和控制语句来转换数据，不能使用 VBA 函数。
- 这种方法不会传输格式。
-
INSERT INTO 要求源和目标具有相同数量的字段，具有相同的数据类型。 （在这种情况下，可以修改 SQL 以插入不同的目标字段集或顺序，并使用不同的源字段）。
- Excel 有时会对列数据类型感到困惑。
- 较新版本的 Office (2010+) 不允许使用纯 SQL 插入/更新 Excel 文件。您将收到以下消息：您无法编辑此字段，因为它位于链接的 Excel 电子表格中。在此 Access 版本中，已禁用在链接的 Excel 电子表格中编辑数据的功能。
- 仍然可以从输入文件中读取，并从中创建 ADO 记录集。 Excel 有一个CopyFromRecordset 方法，它可能比使用
INSERT INTO 有用。
- 仍然允许旧的 Jet 提供程序执行此操作，但这意味着只有
.xls 输入和输出，没有 .xlsx。 （当然，您可以使用自动化打开.xls 文件并将其保存为.xlsx。）
- 通过 OpenSchema 读取工作表名称时，如果启用了 AutoFilter，每个工作表将有一个额外的表 -- 对于
'Sheet1$'，将有 'Sheet1$'FilterDatabase（或使用 Jet 提供程序时的 Sheet1$_）。
添加对 Microsoft ActiveX 数据对象的引用（工具 -> 引用...）。 （选择最新版本；通常是 6.1）。
输出工作簿和工作表应该存在。此外，在运行此代码时，应关闭输入和输出工作簿。
Dim filepath As Variant
Dim outputFilePath As String
Dim outputSheetName As String
'To which file and sheet within the file should the output go?
outputFilePath = "c:\path\to\ouput.xls"
outputSheetName = "Sheet1"
For Each filepath In Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
Dim conn As New ADODB.Connection
Dim schema As ADODB.Recordset
Dim sql As String
Dim sheetname As Variant
With conn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=""" & filepath & """;" & _
"Extended Properties=""Excel 12.0;HDR=No"""
'To use the old Microsoft Jet provider:
'.Provider = "Microsoft.Jet.OLEDB.4.0"
'.ConnectionString = "Data Source=""" & filepath & """;" & _
' "Extended Properties=""Excel 8.0;HDR=No"""
.Open
End With
Set schema = conn.OpenSchema(adSchemaTables)
For Each sheetname In schema.GetRows(, , "TABLE_NAME") 'returns a 2D array of one column
'This appends the data into an existing worksheet
sql = _
"INSERT INTO [" & outputSheetName & "$] " & _
"IN """ & outputFilePath & """ ""Excel 12.0;"" " & _
"SELECT * " & _
"FROM [" & sheetname & "]"
'To create a new worksheet, use SELECT..INTO:
'sql = _
' "SELECT * " & _
' "INTO [" & outputSheetName & "$] " & _
' "IN """ & outputFilePath & """ ""Excel 12.0;"" " & _
' "FROM [" & sheetname & "]"
conn.Execute sql
Next
Next
Dim wbk As Workbook
Set wbk = Workbooks.Open(outputFilePath)
wbk.Worksheets(outputSheetName).Coluns.AutoFit
另一种方法是使用 ADODB 将数据读入记录集，然后使用 CopyFromRecordset 方法将其粘贴到输出工作簿中：
Dim filepath As Variant
Dim outputFilePath As String
Dim outputSheetName As String
Dim sql As String
Dim wbk As Workbook, wks As Worksheet
Dim rng As Excel.Range
Dim sheetname As Variant
'To which file and sheet within the file should the output go?
outputFilePath = "c:\path\to\ouput.xlsx"
outputSheetName = "Sheet1"
For Each filepath In Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
Set schema = conn.OpenSchema(adSchemaTables)
For Each sheetname In schema.GetRows(, , "TABLE_NAME") 'returns a 2D array of one column
sql = sql & _
"UNION ALL SELECT F1 " & _
"FROM [" & sheetname & "]" & _
"IN """ & filepath & """ ""Excel 12.0;"""
Next
Next
sql = Mid(sql, 5) 'Gets rid of the UNION ALL from the first SQL
Dim conn As New ADODB.Connection
Dim rs As ADODB.Recordset
With conn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=""" & filepath & """;" & _
"Extended Properties=""Excel 12.0;HDR=No"""
.Open
Set rs = .Execute(sql)
Set wbk = Workbooks.Open(outputFilePath, , True)
Set wks = wbk.Sheets(outputSheetName)
wks.Cells(2, 1).CopyFromRecordset rs
wks.Columns.AutoFill
.Close
End With
Jet SQL：
ADO：
另请参阅this 答案，它正在做类似的事情。