Copy Columns With Specific Headers--Paste Into Separate Workbook Based On Header

[accell]

Source file has headers:

'Title 1','Title 2','Title 3','Title 4','Title 5'

I only want to copy specific columns based on the header (ie 'Title 2' & 'Title 5') and paste into another workbook based on the address of those headers in the destination file. Destination file is a template and can always be opened through the same filepath in the Macro.

Thanks

[patel]

can you attach samples ?

[accell]

Source File Example:
The header row is actually row 14. I was planning on deleting the above rows before running this macro but ideally I could write a macro that searched for the location of ‘brand title’ in column A and used that position as the reference for the header row. The file arrangement can vary slightly (rows above header line/order of columns) that is why it will be important to move the data based on the header title instead of just static column references. I would like to capture the data starting below the header line to the last row that contains data (this will vary with each file), in this example, rows 15-33 for each selected column.

Destination File:
There is a total bar that contains text and some formulas on row 501.

Header Mapping: Contained as a sheet in the example workbook. If a column header in the source file is not contained in the mapping listed then it should just be ignored.

Thank you!

[mancubus]

hi.
try this.

Sub copy_cols_based_on_header()


    Dim SourceWB As Workbook, HeadWS As Worksheet
    Dim HeadRange As Range, Heads()
    Dim LastHead As Long, j As Long
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    
    Set SourceWB = ThisWorkbook
    Set HeadWS = SourceWB.Worksheets("Header Map")
    
    With HeadWS
        LastHead = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set HeadRange = .Range("A2:A" & LastHead)
        ReDim Heads(LastHead - 2) '-1 for header row in header map and -1 for 0 based arrary
        Heads = HeadRange.Value
    End With
    
    SourceWB.Worksheets("Source File").Copy
    
    With ActiveSheet
        '.Cells.UnMerge 'uncomment this line if you want merged cells to be unmerged
        HeadRow = .Columns(1).Find("Brand Title").Row
        .Rows("1:" & HeadRow - 1).EntireRow.Delete
        For j = .Cells(1, .Columns.Count).End(xlToLeft).Column To 1 Step -1
            If IsError(Application.Match(.Cells(1, j), Heads, False)) Then .Columns(j).Delete
        Next
        HeadRange.Offset(, 1).Copy
        .Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
    End With
    ActiveWorkbook.SaveAs SourceWB.Path & "\DestinationFile.xlsm", 52 'change file path and name to suit your requirement
    
    With Application
        .CutCopyMode = False
        .Calculation = xlCalculationAutomatic
    End With


End Sub