如何使用特定标头合并多个工作簿

Question

我有数百个Excel文件需要合并，但我只需要每个文件中具有相同标题的一些特定列。因为excel标题到处都是，所以我不能按列号(或字母)合并它们，而是按标题合并。这样，我就可以拥有一个工作簿，所有数据都在同一个标题下。

我目前已经成功地将所有工作簿合并到一个主文件中，但是列都是乱七八糟的，所以代码真的对我的问题没有帮助。其主要思想是:从路径中找到的每个文件中复制、粘贴和循环特定的列到新的WB。

'Merge all WB in a folder
Sub FileMerger()
    Dim bookList As Workbook
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    Application.ScreenUpdating = False
    Set mergeObj = CreateObject("Scripting.FileSystemObject")


    Set dirObj = mergeObj.Getfolder("Here is the path were all my excel files are found.xml")  'PATH
    Set filesObj = dirObj.Files

    For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)

        Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy                                         'A65536 is the last row for Colmn A
        ThisWorkbook.Worksheets(1).Activate

        Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
        Application.CutCopyMode = False
        bookList.Close
    Next
End Sub

正如您从我的代码中看到的，它只是代码的合并部分，因为我不知道如何添加该部分以仅合并特定的头。

如果你能帮我完成这段代码，我将不胜感激。对于标头，您可以使用"Header1“、"Header2”、"Header3“、"Header4”和"Header5“作为示例。我已经尝试了几天来完成这段代码，它是完成我的项目的唯一缺失的部分。

Answer 1

在这里，我注释了代码，但您可以询问是否有未添加的内容或需要进一步解释：

    Option Explicit
    Sub FileMerger()

        Dim bookList As Workbook, ws As Worksheet
        Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
        Dim bookListlrow As Long, wblrow As Long, i As Long, MasterHeader As Integer
        Dim arrHeaders, HeaderFind

        Application.ScreenUpdating = False

        Set ws = ThisWorkbook.Sheets("MasterWorksheet") 'change "MasterWorksheet" for the name of your sheet (in the master wb)
        arrHeaders = Array("Header1", "Header2", "Header3", "Header4") 'here you define all the headers you want to look for

        Set mergeObj = CreateObject("Scripting.FileSystemObject")
        Set dirObj = mergeObj.Getfolder("Here is the path were all my excel files are found.xml")  'PATH
        Set filesObj = dirObj.Files

        For Each everyObj In filesObj
            'is better to avoid the update and to open it as readonly to avoid potential errors in case someone else opens it
            Set bookList = Workbooks.Open(everyObj, UpdateLinks:=False, ReadOnly:=True)
            With bookList.Sheets(1) 'assuming your first sheet on the workbook is the one to copy
                For i = LBound(arrHeaders) To UBound(arrHeaders) 'a loop through all your headers
                    'header on your master worksheet. I declared it as integer because I expect all the headers to be on this sheet.
                    MasterHeader = Application.Match(arrHeaders(i), ws.Rows(1), 0)
                    'set the last row for your main workbook
                    wblrow = ws.Cells(ws.Rows.Count, MasterHeader).End(xlUp).Row + 1
                    HeaderFind = Application.Match(arrHeaders(i), .Rows(1), 0) 'this is assuming all your headers are on row 1
                    If Not IsError(HeaderFind) Then 'if we get a match on the header we copy the column
                        bookListlrow = .Cells(.Rows.Count, HeaderFind).End(xlUp).Row 'last row on that sheet
                        'copy paste on the same move since you are not pating values but everything.
                        .Range(.Cells(2, HeaderFind), .Cells(bookListlrow, HeaderFind)).Copy ws.Cells(wblrow, MasterHeader)
                    End If
                Next i
                Application.CutCopyMode = False
            End With
            bookList.Close SaveChanges:=False
        Next everyObj

        Applicaiton.ScreenUpdating = True

    End Sub

Answer 2

我只想先检查一下，在您将所有工作簿合并为一个工作簿后，所有数据现在都可以在一个工作表中找到吗？你的工作表看起来像下面的截图吗？

​

​