从所选工作簿中的多个工作表获取数据 [英] Get data from multiple sheets in a selected workbook

问题描述

我刚刚在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 Nile As Long 
 Dim WorkBk As Workbook 
 Dim SourceRange As Range 
 Dim DestRange As Range 
 
'创建一个新的工作簿并设置一个变量第一张。 
设置SummarySheet = Workbooks.Add（xlWBATWorksheet）.Worksheets（1）
 
'修改此文件夹路径以指向要使用的文件。 
 FolderPath =C：\Users\My\Desktop\Path
 
'将当前目录设置为文件夹路径。 
 ChDrive FolderPath 
 ChDir FolderPath 
 
'打开文件对话框并对Excel文件进​​行过滤，允许选择多个文件
'。 
 SelectedFiles = Application.GetOpenFilename（_ 
 filefilter：=Excel Files（* .xl *），* .xl *，MultiSelect：= True）
 
'NRow保持跟踪在目标工作簿中插入新行的位置。 
 NRow = 1 
 
'循环通过返回的文件名列表
对于NFile = LBound（SelectedFiles）到UBound（SelectedFiles）
'将FileName设置为当前工作簿文件名打开。 
 FileName = SelectedFiles（NFile）
 
'打开当前工作簿。 
设置WorkBk = Workbooks.Open（FileName）
 
 
'将源范围设置为A9到C9。 
'修改您的工作簿的范围。它可以跨多行。 
设置SourceRange = WorkBk.Worksheets（1）.Range（A1：G5）
 
'将目标范围设置为从B开始，与源范围大小相同。 
设置DestRange = SummarySheet.Range（A& NRow）
设置DestRange = DestRange.Resize（SourceRange.Rows.Count，_ 
 SourceRange.Columns.Count）
 
'将来自源的值复制到目的地。 
 DestRange.Value = SourceRange.Value 
 
'增加NRow，以便我们知道在哪里复制数据。 
 NRow = NRow + DestRange.Rows.Count 
 
'关闭源工作簿而不保存更改。 
 WorkBk.Close savechanges：= False 
下一个NFile 
 
'在目标表上调用AutoFit，以便所有数据都可读。 
 SummarySheet.Columns.AutoFit 
 End Sub 
  

解决方案

要使用Excel Automation执行此操作，首先要使用以下技术定义以下函数，该函数将使用这里：

 功能LastUsedCell（wks As Excel.Worksheet）作为Excel.Range 
与wks 
如果Application.WorksheetFunction.CountA（.Cells）<> 0然后
设置LastUsedCell = .Cells.Find（什么：=*，_ 
之后：=。范围（A1），_ 
 Lookat：= xlPart，_ 
 LookIn：= xlFormulas，_ 
 SearchOrder：= xlByRows，_ 
 SearchDirection：= xlPrevious，_ 
 MatchCase：= False）
 End If 
 End With 
结束函数
  

和这个帮助函数，以确定从每个工作表开始复制数据的位置：

 函数GetNextRowStart（wks As Excel.Worksheet）作为Excel.Range 
 Dim lastCell As Excel.Range 
 Dim nextRow As Integer 
 nextRow = 1 
设置lastCell = LastUsedCell（wks）
如果不是lastCell是Nothing Then nextRow = lastCell.Row + 1 
设置GetNextRowStart = wks。单元格（nextRow，1）
结束函数
  

然后可以使用以下代码： / p>

  Dim outputWorkbook作为Excel.Workbook 
 Dim outputWorksheet作为Excel.Worksheet 
 D im filepath As Variant 
 
设置outputWorkbook = Workbooks.Open（D：\Zev\Clients\stackoverflow\outputMultipleWokrbooksWithADO\output.xlsx）
设置outputWorksheet = outputWorkbook。 （Sheet1）
 
对于每个文件路径在Application.GetOpenFilename（FileFilter：=Excel Files（* .xl *），* .xl *，MultiSelect：= True）
 Dim wkbk As Excel.Workbook 
 Dim wks As Excel.Worksheet 
设置wkbk = Workbooks.Open（filepath，，True）
对于每个wks在wkbk.Sheets 
 Dim sourceRange As Excel.Range 
 Dim outputRange As Excel.Range 
使用wks 
设置sourceRange = .Range（.Cells（1，1），LastUsedCell（wks））
 End with 
设置outputRange = GetNextRowStart（outputWorksheet）
 sourceRange.Copy outputRange 
下一个
下一个
 
 outputWorksheet.Columns.AutoFit 
  

---

以前的方法使用Excel Automation - 打开wo rkbook，获取表单，操作源和输出表上的范围。

您还可以使用ADODB来读取Excel表格，就像工作簿是数据库一样工作表是其表;然后发出一个 INSERT INTO 语句将原始记录复制到输出工作簿中。它提供以下优点：

• 作为一般规则，通过自动化传输数据的速度比传输数据快（打开工作簿，复制并粘贴范围）。
  
  
  
  
  • 如果没有数据转换，另一个选项是读取 Value 范围对象，返回一个二维数组。这可以很容易地被分配/粘贴到任何期望这样的数组，包括值属性本身。
  
  


• 使用SQL转换数据是声明式的 - 只需定义新的数据形式。相比之下，使用自动化来转换数据意味着读取每一行并在每行上运行一些代码。
  
  
  
  
  • 更多的声明性选项可能是将Excel公式写入其中一列，并复制并粘贴值。
  
  

但是，它受到以下限制：

• 这可以通过发出一个SQL语句。如果你不熟悉SQL，这可能对你没有用。


• 只能用SQL支持的函数和控制语句来转换数据 - 没有VBA函数。 >
  
• 此方法不会转换格式。


• INSERT INTO 要求源和目的地具有相同数量的字段，具有相同的数据类型。 （在这种情况下，可以修改SQL以插入目标字段的不同集合或顺序，并使用不同的源字段）。


• Excel有时会对列数据类型感到困惑。


• 较新版本的Office（2010+）将不允许使用纯SQL插入/更新Excel文件。您将收到以下消息：您无法编辑此字段，因为它位于链接的Excel电子表格中。在此Access版本中，已禁用在链接的Excel电子表格中编辑数据的功能。
  
  
  
  
  • 仍然可以从输入文件中读取，并从中创建一个ADO Recordset。 Excel有一个 CopyFromRecordset 方法，可能有用而不是使用 INSERT INTO 。
  
  
  • 旧的Jet提供者仍然允许这样做，但这只意味着。 xls 输入和输出，没有 .xlsx 。
  
  


• 当通过OpenSchema读取工作表名称时，如果AutoFilter打开，每个工作表将会有一个额外的表 - 对于'Sheet1 $'，将会有code>'Sheet1 $'FilterDatabase （或 Sheet1 $ _ 使用Jet提供者）。

---

添加引用（工具 - > 引用... ）到 Microsoft ActiveX数据对象。 （选择最新版本，通常为6.1）。

输出工作簿和工作表应该存在。此外，输入和输出工作簿应该在运行此代码时关闭。

  Dim filepath As Variant 
 Dim outputFilePath作为String 
 Dim outputSheetName As String 
 
'文件中的哪个文件和工作表应该输出？ 
 outputFilePath =c：\path\to\ouput.xls
 outputSheetName =Sheet1
 
对于每个文件路径在Application.GetOpenFilename（FileFilter：= Excel文件（* .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 =&文件路径&  ; &安培; _ 
扩展属性=Excel 12.0; HDR =否
 
'要使用旧的Microsoft Jet提供程序：
'.Provider =Microsoft.Jet。 OLEDB.4.0
'.ConnectionString =Data Source =&文件路径&  ; &安培; _ 
'扩展属性=Excel 8.0; HDR =否
 
 .Open 
结束
设置schema = conn.OpenSchema（adSchemaTables） 
对于每个sheetname在schema.GetRows（，TABLE_NAME）'返回一列二维数组
'这将数据附加到现有工作表中
 sql = _ 
 INSERT INTO [& outputSheetName& $& _ 
IN& outputFilePath& Excel 12.0;& _ 
SELECT *& _ 
FROM [&表单& ]
 
'要创建新工作表，请使用SELECT..INTO：
'sql = _ 
'SELECT *& _ 
'INTO [& outputSheetName& $& _ 
'IN& outputFilePath& Excel 12.0;& _ 
'FROM [&表单& ]
 
 conn.Execute sql 
下一个
下一个
 
 Dim wbk As Workbook 
设置wbk = Workbooks.Open（outputFilePath） 
 wbk.Worksheets（outputSheetName）.Coluns.AutoFit 
  

---

$ b $另一种方法是使用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作为Excel.Range 
 Dim sheetname As Variant 
 
'文件中的哪个文件和工作表应该输出？ 
 outputFilePath =c：\path\to\ouput.xlsx
 outputSheetName =Sheet1
 
对于每个文件路径在Application.GetOpenFilename（FileFilter：= Excel文件（* .xl *），* .xl *，MultiSelect：= True）
设置schema = conn.OpenSchema（adSchemaTables）
对于每个sheetname在schema.GetRows（，TABLE_NAME ）'返回一列的二维数组
 sql = sql& _ 
UNION ALL SELECT F1& _ 
FROM [&表单& ]& _ 
IN&文件路径& Excel 12.0;
下一个
下一个
 sql = Mid（sql，5）'从第一个SQL 
 $ b中删除UNION ALL $ b Dim conn As New ADODB.Connection 
 Dim rs As ADODB.Recordset 
 With conn 
 .Provider =Microsoft.ACE.OLEDB.12.0
 .ConnectionString =Data Source =&文件路径&  ; &安培; _ 
扩展属性=Excel 12.0; HDR =否
 .Open 
设置rs = .Execute（sql）
设置wbk = Workbooks.Open（outputFilePath ，，True）
设置wks = wbk.Sheets（outputSheetName）
 wks.Cells（2，1）.CopyFromRecordset rs 
 wks.Columns.AutoFill 
 .Close 
结束
  

Jet SQL：

• INSERT INTO语句


• IN子句

ADO：

• 使用ADO查询Excel工作表


• 使用ADO连接到Excel工作簿


• OpenSchema方法


• GetRows方法

另请参见这个回答，这是做类似的事情。

I'm new to macros in Excel and I need to make a macro that get data from multiple sheets in a selected workbook.

So far I have this code to select a file and get data from sheet 1, but I want it to be able to get information from all the sheets in the selected file.

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

解决方案

To do this with Excel Automation, first define the following function, which gets the last used cell in a worksheet, using the technique outlined 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

and this helper function, to determine where to start copying the data from each worksheet:

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

Then you can use the following code:

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

---

The previous approach uses Excel Automation -- open the workbook, get a hold of the sheet, manipulate ranges on the source and output sheets.

You can also use ADODB to read the Excel sheets as if the workbook was a database and the worksheets were its tables; and then issue an INSERT INTO statement to copy the original records into the output workbook. It offers the following benefits:

• As a general rule, transferring data via SQL is faster then transferring data via Automation (opening the workbook, copying and pasting the range).
  • If there is no transformation of the data, another option is to read the Value property of a Range object, which returns a two-dimensional array. This can easily be assigned / pasted to anything which expects such an array, including the Value property itself.
• Transforming data with SQL is declarative -- just define the new form of the data. In contrast, transforming the data with Automation implies reading each row and running some code on each row.
  • A more declarative option might be to write an Excel formula into one of the columns, and copy and paste the values.

However, it suffers from the following limitations:

• This works by issuing an SQL statement. If you are not familiar with SQL, this may not be useful to you.
• The data can be transformed only with SQL-supported functions and control statements -- no VBA functions.
• This approach doesn't transfer the formatting.
• INSERT INTO requires that the source and the destination have the same number of fields, with the same data types. (In this case, the SQL can be modified to insert to a different set or order of destination fields, and to use different source fields).
• Excel sometimes gets confused about the column data types.
• Newer versions of Office (2010+) will not allow inserting/updating an Excel file with pure SQL. You'll get the following message: You cannot edit this field because it resides in a linked Excel spreadsheet. The ability to edit data in a linked Excel spreadsheet has been disabled in this Access release.
  • It is still possible to read from the input files, and create an ADO Recordset from them. Excel has a CopyFromRecordset method, that might be useful instead of using INSERT INTO.
  • The old Jet provider is still allowed to do this, but that means only .xls input and output, no .xlsx.
• When reading the worksheet names via OpenSchema, if AutoFilter is turned on, there will be an extra table per worksheet -- for 'Sheet1$', there will be 'Sheet1$'FilterDatabase (or Sheet1$_ when using the Jet provider).

---

Add a reference (Tools -> References ...) to Microsoft ActiveX Data Objects. (Choose the latest version; it's usually 6.1).

The output workbook and worksheet should exist. Also, both the input and output workbooks should be closed while running this code.

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

---

An alternate approach is to read the data with ADODB into a recordset and then paste it into the output workbook using the CopyFromRecordset method:

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 statement
• IN clause

ADO:

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

See also this answer, which is doing something similar.

这篇关于从所选工作簿中的多个工作表获取数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！