Как объединить несколько рабочих книг, используя определенные заголовки

Question

У меня есть сотни файлов Excel, которые мне нужно объединить, но мне нужны только отдельные столбцы с одинаковым заголовком из каждого файла.Поскольку заголовки Excel находятся повсюду, я не могу объединить их по номерам столбцов (или букве), но по заголовкам.Таким образом, у меня может быть одна рабочая книга со всеми данными, находящимися в одном заголовке.

В настоящее время я успешно объединил все рабочие книги в один главный файл, но со столбцами, которые все перепутаны, поэтому код действительно не работаетпомогите моей проблеме.Основная идея состоит в том, чтобы: Скопировать, вставить и зациклить определенные столбцы из каждого файла, найденного в пути к новому ББ.

'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

Я просто хочу сначала проверить, все ли данные теперь можно найти в одном листе после объединения всей вашей книги в одну? Ваш рабочий лист похож на скриншот ниже?