将多个 Excel 工作簿合并为一个 [关闭]

Question

更新：

以下是我在joinedupdata.com 上找到的示例VBA 代码。我需要帮助进行两项修改：（1）删除删除重复标题行的条件，（2）查看是否有办法将每个 Excel 文件中的连接数据通过文件名的组合工作表中的空白行分开下表在最左边的单元格中。

Dim firstRowHeaders As Boolean
Dim fso As Object
Dim dir As Object
Dim filename As Variant
Dim wb As Workbook
Dim s As Sheet1
Dim thisSheet As Sheet1
Dim lastUsedRow As Range
Dim file As String

On Error GoTo ErrMsg

Application.ScreenUpdating = False
firstRowHeaders = True 'Change from True to False if there are no headers in the first row

Set fso = CreateObject("Scripting.FileSystemObject")

'PLEASE NOTE: Change <<Full path to your Excel files folder>> to the path to the folder containing your Excel files to merge
Set dir = fso.Getfolder("<<Full path to your Excel files folder>>")

Set thisSheet = ThisWorkbook.ActiveSheet

For Each filename In dir.Files
    'Open the spreadsheet in ReadOnly mode
    Set wb = Application.Workbooks.Open(filename, ReadOnly:=True)

    'Copy the used range (i.e. cells with data) from the opened spreadsheet
    If firstRowHeaders And i > 0 Then 'Only include headers from the first spreadsheet
        Dim mr As Integer
        mr = wb.ActiveSheet.UsedRange.Rows.Count
        wb.ActiveSheet.UsedRange.Offset(1, 0).Resize(mr - 1).Copy
    Else
        wb.ActiveSheet.UsedRange.Copy
    End If

     'Paste after the last used cell in the master spreadsheet
    If Application.Version < "12.0" Then 'Excel 2007 introduced more rows
        Set lastUsedRow = thisSheet.Range("A65536").End(xlUp)
    Else
        Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp)
    End If

    'Only offset by 1 if there are current rows with data in them
    If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then
        Set lastUsedRow = lastUsedRow.Offset(1, 0)
    End If
    lastUsedRow.PasteSpecial
    Application.CutCopyMode = False
Next filename

ThisWorkbook.Save
Set wb = Nothing

#If Mac Then
    'Do nothing. Closing workbooks fails on Mac for some reason
#Else
    'Close the workbooks except this one
    For Each filename In dir.Files
        file = Right(filename, Len(filename) - InStrRev(filename, Application.PathSeparator, , 1))
        Workbooks(file).Close SaveChanges:=False
    Next filename
    #End If

    Application.ScreenUpdating = True
    ErrMsg:
    If Err.Number <> 0 Then
    MsgBox "There was an error. Please try again. [" & Err.Description & "]"
    End If

我一直在尝试（但没有取得多大成功）找到一种将多个 Excel 电子表格合并为一个的方法。我正在使用 MATLAB 分析实验数据。输入一打 Excel 电子表格，输出等量。

电子表格结构：

每个 Excel 文件中的数据仅在第一张表（Sheet 1）上。

每张工作表有四列数据（带有标题）和下面可变数量的数据行。

每个 Excel 文件都有一个唯一的文件名。

示例：

Header 1 | Header 2 | Header 3 | Header 4
1111       22222      3333       4444
11122      11223      33344      33444
etc        etc        etc        etc

首选合并行为：

1) 多个 Excel 文件合并到一个新电子表格上的一个工作表中。

2) 在合并期间维护列标题。

3) 与其将每个连续数据集添加到前一个数据集的底部（“垂直”添加），不如将列与一个并排放置（“水平”添加） - 中间的分栏。

4) 每个原始文件的文件名放在第一列标题上方的一行中。

5) 最好是跨平台的（Windows/Mac OS X）。但是，如果 VBA 和 ActiveX 是唯一的方法，那也没关系。

样本输出：

Filename1                                     Filename2                
Header 1 | Header 2 | Header 3 | Header 4     Header 1 | Header 2 | Header 3 | ...
111        22222      33333      4444         1111        222222    44444
Data...    Data...    Data...    Data...      Data...     Data...   Data...

Answer 1

一个简单的循环遍历与主工作簿相同文件夹中的工作簿就足够了。

Sub collect_wb_data()
    Dim wbm As Workbook, wb As Workbook
    Dim fp As String, fn As String, nc As Long

    'Application.ScreenUpdating = False
    Set wbm = ThisWorkbook
    With wbm.Worksheets("sheet1")   'set this properly to the receiving worksheet in the master workbook

        fp = wbm.Path
        fn = "*.xl*"
        fn = Dir(fp & Chr(92) & fn)

        Do While CBool(Len(fn))
            If Not fn = .Parent.Name Then
                Set wb = Workbooks.Open(Filename:=fp & Chr(92) & fn, _
                                        UpdateLinks:=False, _
                                        ReadOnly:=True)
                nc = nc + 1
                .Cells(1, nc) = Left(fn, InStr(1, fn, Chr(46)) - 1)
                wb.Worksheets(1).Cells(1, 1).CurrentRegion.Copy Destination:=.Cells(2, nc)
                wb.Close SaveChanges:=False
                Set wb = Nothing
                nc = .Cells(2, Columns.Count).End(xlToLeft).Offset(0, 1).Column
            End If
            fn = Dir
        Loop

        '.parent.save   'Uncomment to save before finishing operation
    End With

    Set wbm = Nothing
    Application.ScreenUpdating = True

End Sub

奇怪的是，很少有人提到要处理的工作簿列表是如何得出的。我在主工作簿所在的同一文件夹中使用了一个简单的文件掩码，但我很容易更改它。如果要处理特定文件，则可以从标准文件打开对话框创建多个列表。另一种选择是硬编码的工作簿名称数组。

我已将一些命令（例如禁用屏幕更新、完成前保存）注释掉了。一旦您对方法感到满意，您可能需要取消注释。