在选定的工作簿

Question

我是新来的Excel宏和我需要做的是让在选定的工作簿的多个工作表的数据宏获得来自多个工作表的数据。

到目前为止，我有这样的代码来选择一个文件，并从表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自动化做到这一点，首先定义下面的函数，它得到最后使用的电池在工作表，使用该技术概述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转换数据是声明 - 只是定义了数据的新形式。相反，使用Automation转换数据意味着读取每行并在每行上运行一些代码。
  • 更声明的选择可能是写一个Excel公式为一列，复制和粘贴值。

然而，从以下限制患有：

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

---

添加引用（工具 - >引用...）以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 

喷气SQL：

• INSERT INTO statement
• IN clause

ADO：

• Using ADO to Query an Excel Worksheet
• Connecting to an Excel workbook with ADO
• OpenSchema method
• GetRows method

又见this的答案，这是做类似的事情。

Answer 2

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