Code to copy certain columns to new sheet

[ijhoeq]

Hello,

I have a workbook that copy's 'relevant' columns from one sheet to the next (sheet1 to sheet2). I used the code below to accomplish this.

With Worksheets("Sheet1")
    .Range("B1", .Range("B" & Rows.Count).End(xlUp)).Copy Worksheets("Sheet2").Range("A1")
    .Range("E1", .Range("E" & Rows.Count).End(xlUp)).Copy Worksheets("Sheet2").Range("B1")
End With

This works great but now the data inputted into sheet1 is not always in the same order. I'd like to write the code so that it searches for certain column headers and then copies that whole column and pastes it into sheet2. Can someone help me out with this?

Thanks!

 

[shknbk2]

Put the column headers that you want to have copied into the HeaderNames string.

Sub CopyColumns()
    Dim FoundCell As Range
    Dim LastCell As Range
    Dim HeaderRange As Range
    Dim HeaderNames As String
    Dim HeaderArray() As String
    Dim ArrayCount As Integer
    Dim ColumnCopy As Integer
    
    'Put column titles that you want to find/copy here separated by comma
    HeaderNames = "Column Header1,Column Header3"
    
    ColumnCopy = 1
    HeaderArray = Split(HeaderNames, ",")
    With Worksheets("Sheet1")
        Set HeaderRange = .Range(.Range("A1"), .Cells(1, .Columns.Count).End(xlToLeft))
        Set LastCell = HeaderRange.Cells(HeaderRange.Cells.Count)
        For ArrayCount = 0 To UBound(HeaderArray)
            Set FoundCell = HeaderRange.Find(what:=HeaderArray(ArrayCount), after:=LastCell)
            If Not FoundCell Is Nothing Then
                .Range(FoundCell, .Cells(.Rows.Count, FoundCell.Column).End(xlUp)).Copy Worksheets("Sheet2").Cells(1, ColumnCopy)
                ColumnCopy = ColumnCopy + 1
            End If
        Next
    End With
End Sub