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