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

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

Answer 2

在这里，我对代码进行了注释，但是您可以询问是否没有添加内容或需要进一步说明：

    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

如何使用特定标题合并几个工作簿

2 个答案: