Code to copy certain columns to new sheet
Results 1 to 2 of 2

Thread: Code to copy certain columns to new sheet
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Jun 2018
    Posts
    39
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Question Code to copy certain columns to new sheet

    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!

  2. #2
    Board Regular
    Join Date
    Mar 2016
    Posts
    171
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Code to copy certain columns to new sheet

    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

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •