从选定工作簿中的多个工作表中获取数据

我是新来的macros在Excel中，我需要从选定的工作簿中的多个工作表中获取数据的macros。

到目前为止，我有这个代码来select一个文件，并从表1中获取数据，但我希望它能够从所选文件中的所有工作表中获取信息。

Sub MergeSelectedWorkbooks() Dim SummarySheet As Worksheet Dim FolderPath As String Dim SelectedFiles() As Variant Dim NRow As Long Dim FileName As String Dim NFile As Long Dim WorkBk As Workbook Dim SourceRange As Range Dim DestRange As Range ' Create a new workbook and set a variable to the first sheet. Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1) ' Modify this folder path to point to the files you want to use. FolderPath = "C:\Users\My\Desktop\Path" ' Set the current directory to the the folder path. ChDrive FolderPath ChDir FolderPath ' Open the file dialog box and filter on Excel files, allowing multiple files ' to be selected. SelectedFiles = Application.GetOpenFilename( _ filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True) ' NRow keeps track of where to insert new rows in the destination workbook. NRow = 1 ' Loop through the list of returned file names For NFile = LBound(SelectedFiles) To UBound(SelectedFiles) ' Set FileName to be the current workbook file name to open. FileName = SelectedFiles(NFile) ' Open the current workbook. Set WorkBk = Workbooks.Open(FileName) ' Set the source range to be A9 through C9. ' Modify this range for your workbooks. It can span multiple rows. Set SourceRange = WorkBk.Worksheets(1).Range("A1:G5") ' Set the destination range to start at column B and be the same size as the source range. Set DestRange = SummarySheet.Range("A" & NRow) Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _ SourceRange.Columns.Count) ' Copy over the values from the source to the destination. DestRange.Value = SourceRange.Value ' Increase NRow so that we know where to copy data next. NRow = NRow + DestRange.Rows.Count ' Close the source workbook without saving changes. WorkBk.Close savechanges:=False Next NFile ' Call AutoFit on the destination sheet so that all data is readable. SummarySheet.Columns.AutoFit End Sub 

Answer 1

要使用Excel自动化function执行此操作，请首先使用下面列出的技术定义以下函数，该函数获取工作表中最后使用的单元格：

 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语句将原始logging复制到输出工作簿。 它提供了以下好处：

• 作为一般规则，通过SQL传输数据通过自动化传输数据（打开工作簿，复制和粘贴范围）更快。
  • 如果没有数据转换，另一个select是读取Range对象的Value属性，它返回一个二维数组。 这可以很容易地分配/粘贴到任何期望这样的数组，包括Value属性本身。
• 用SQL转换数据是声明式的 – 只需定义新的数据forms即可。 相反，使用Automation转换数据意味着读取每一行并在每行上运行一些代码。
  • 更具说明性的选项可能是将Excel公式写入其中一列，然后复制并粘贴这些值。

但是，它受到以下限制：

• 这通过发出一个SQL语句来工作。 如果你不熟悉SQL，这可能对你没有用处。
• 数据只能用SQL支持的函数和控制语句进行转换 – 没有VBA函数。
• 这种方法不会传输格式。
• INSERT INTO要求源和目的地具有相同数量的字段，具有相同的数据types。 （在这种情况下，可以修改SQL以插入到不同的目标字段集合或顺序，并使用不同的源字段）。
• Excel有时会对列数据types感到困惑。
• 较新版本的Office（2010+）不允许使用纯SQL插入/更新Excel文件。 您将收到以下消息： 您无法编辑此字段，因为它驻留在链接的Excel电子表格中。 在此Access版本中，已禁用在链接的Excel电子表格中编辑数据的function。
  • 仍然可以从input文件读取，并从它们创build一个ADOlogging集。 Excel有一个CopyFromRecordset方法，这可能是有用的，而不是使用INSERT INTO 。
  • 旧的Jet提供程序仍然可以这样做，但这意味着只有.xlsinput和输出，没有.xlsx 。
• 当通过OpenSchema读取工作表名称时，如果启用了AutoFilter，则每个工作表将会有一个额外的表格。对于'Sheet1$' ，将会有'Sheet1$'FilterDatabase （或者使用Jet提供程序时的Sheet1$_ ）。

---

添加引用（ 工具 – > 引用… ）到Microsoft ActiveX数据对象 。 （select最新版本，通常是6.1）。

输出工作簿和工作表应该存在。 另外，运行此代码时，输​​入和输出工作簿都应该closures。

 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将数据读取到logging集中，然后使用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：

• INSERT INTO语句
• IN子句

ADO：

• 使用ADO查询Excel工作表
• 使用ADO连接到Excel工作簿
• OpenSchema方法
• GetRows方法

另请参阅这个答案，它正在做类似的事情。

Answer 2

你可以试试这个： https : //msdn.microsoft.com/en-us/library/office/gg549168(v=office.14).aspx我不知道它是否有帮助。