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

Question

我是 Excel 中宏的新手，我需要制作一个宏来从 selected 工作簿中的多个 sheet 获取数据。

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

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 自动化执行此操作，请首先定义以下函数，该函数获取作品中最后使用的单元格sheet，使用概述的技术 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

和这个辅助函数，确定从哪里开始复制每个作品的数据sheet:

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\Whosebug\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 自动化——打开工作簿，获取 sheet，操纵源和输出 sheet 的范围。在移动过程中，数据可以按原样复制或以某种方式转换。

您还可以使用 ADODB 读取 Excel sheet，就好像工作簿是一个数据库，工作sheet 是它的 table；然后发出 INSERT INTO 语句将原始记录复制到输出工作簿中。它具有以下优势：

作为一般规则，通过 SQL 传输数据比通过自动化传输数据（打开工作簿、复制和粘贴范围）更快。
- 如果没有数据的转换，另一种选择是读取Range对象的Value属性，其中returns一个二维数组.这可以很容易地分配/粘贴到任何需要这样一个数组的东西，包括 Value 属性本身。
使用 SQL 转换数据是声明式的——只需定义数据的新形式。相比之下，使用自动化转换数据意味着读取每一行并且运行每行上的一些代码。
- 一个更具说明性的选择可能是将 Excel 公式写入其中一列，然后复制并粘贴值。

但是，它有以下限制：

这通过发出 SQL 语句来实现。如果您不熟悉 SQL，这可能对您没有用。
只能使用 SQL 支持的函数和控制语句转换数据 -- 没有 VBA 函数。
此方法不传输格式。
INSERT INTO 要求源和目标具有相同数量的字段，具有相同的数据类型。（在这种情况下，可以修改 SQL 以插入不同的目标字段集或顺序，并使用不同的源字段）。
Excel 有时会对列数据类型感到困惑。
较新版本的 Office (2010+) 将不允许 inserting/updating 具有纯 SQL 的 Excel 文件。您将收到以下消息：您无法编辑此字段，因为它位于链接的 Excel 传播 sheet 中。在此 Access 版本中已禁用在链接的 Excel 传播sheet 中编辑数据的功能。
- 仍然可以从输入文件中读取，并从中创建 ADO 记录集。 Excel 有一个 CopyFromRecordset 方法，它可能比使用 INSERT INTO.
- 仍然允许旧的 Jet 提供程序执行此操作，但这意味着只有 .xls 输入和输出，没有 .xlsx。（当然，您随后可以使用自动化打开 .xls 文件并将其另存为 .xlsx。）
当通过 OpenSchema 读取作品sheet 名称时，如果打开自动筛选，每个作品将有一个额外的 table sheet -- 对于 'Sheet1$'，将有 'Sheet1$'FilterDatabase（或使用 Jet 提供程序时 Sheet1$_）。

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

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

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:

ADO:

另见 this 答案，它正在做类似的事情。

Answer 2

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

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

Get data from multiple sheets in a selected workbook

excel

vba

excel-2007