Pulling data from multiple workbooks to a master workbook using headers

[RedVines]

I have three workbooks that I am trying to move into one by matching the headers (we’ll refer to the workbooks as WB1, WB2, WB3 and the new as the master sheet). Some information about the existing workbooks and the master sheet.

Master sheet is blank, except for the headers. Headers match headers used on WB1, WB2, and WB3, but may be in a different order.

Not all headers from WB1, WB2, and WB3 will be used on the mater sheet.

Some headers from WB1, WB2, and WB3 are duplicative, I would want to pull the data anyways but would not want to overwrite information from another workbook. I have plans to go back and dedupe once all of my data is transferred.

Some headers on WB1 do not match headers of WB2 or WB3 but do match some headers on the master sheet.

Some headers from WB2 do not match headers from WB1 or WB3, but do match some headers on the master sheet.

Some headers from WB3 do not match WB1 or WB2, but do match some headers on the master sheet.

Originally, I was going to try and use a index match or vlookup to pull the data, but my formula started to get messy, my VBA skills are practically non-existent. I saw there was a similar post yesterday that used the below, but I wasn’t sure how I could manipulate the code so it would work for me (I did copy the workbooks into various sheets on the master sheet to apply the code below).

(Credit to mumps)

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    Dim LastRow As Long
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim lColumn As Long
    lColumn = srcWS.Cells(1, srcWS.Columns.Count).End(xlToLeft).Column
    Dim header As Range, foundHeader As Range
    For Each header In srcWS.Range(srcWS.Cells(1, 1), srcWS.Cells(1, lColumn))
        Set foundHeader = desWS.Rows(1).Find(header, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundHeader Is Nothing Then
            srcWS.Range(srcWS.Cells(2, header.Column), srcWS.Cells(LastRow, header.Column)).Copy desWS.Cells(2, foundHeader.Column)
        End If
    Next header
    Application.ScreenUpdating = True
End Sub

Apologies if this was confusing and many many many thanks if you are able to assist.

 

[mumps]

The macro assumes that all workbooks are open, the destination sheet is named "Master", all the source sheets are named "Sheet1" and all sheets have headers in row 1 and data starting in row 2. If this is not the case, the sheet names and row numbers in the code will have to be modified. Place the macro in a regular module in the master workbook and run it from there.

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, desWS As Worksheet, WB As Workbook
    Set desWS = ThisWorkbook.Sheets("Master")
    Dim header As Range, foundHeader As Range
    Dim LastRow As Long, lColumn As Long
    For Each WB In Workbooks
        If WB.Name <> ThisWorkbook.Name Then
            Set ws = WB.Sheets("Sheet1")
            LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            lColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
            For Each header In ws.Range(ws.Cells(1, 1), ws.Cells(1, lColumn))
                Set foundHeader = desWS.Rows(1).Find(header, LookIn:=xlValues, lookat:=xlWhole)
                If Not foundHeader Is Nothing Then
                    ws.Range(ws.Cells(2, header.Column), ws.Cells(LastRow, header.Column)).Copy desWS.Cells(desWS.Rows.Count, foundHeader.Column).End(xlUp).Offset(1, 0)
                End If
            Next header
        End If
    Next WB
    Application.ScreenUpdating = True
End Sub