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文件中的数据仅在第一张纸上（工作表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）不是将每个连续数据集添加到前一个数据集的底部（＆＃34;垂直＆＃34;添加），如果列可以并排放置（＆＃34）会很棒;水平＆＃34;加法），中间有一列中断。

4）每个原始文件的文件名放在第一列标题的正上方。

5）最好是跨平台（Windows / Mac OS X）。但是，如果使用带有ActiveX的VBA是唯一的方法，那也很好。

示例输出：

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

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

我已经留下了几个命令（例如禁用屏幕更新，在完成之前保存）注释掉了。一旦您对方法感到满意，您可能想要取消注释这些。

将多个Excel工作簿合并为一个

1 个答案: