Code to copy certain columns to new sheet

ijhoeq

Board Regular
Joined
Jun 20, 2018
Messages
61
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.

Code:
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!
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Put the column headers that you want to have copied into the HeaderNames string.

Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,529
Messages
6,114,155
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top