VBA to find and copy a column with specific header along with multiple adjacent columns to the right

I'm trying to use VBA to find the Sheet1 column header “Country”, and copy it along with the 20 columns to the right of it, to to Sheet2 column A

I have tried:

Dim lr As Long, lc As Long, Col as Long

With ThisWorkbook.Worksheets("Sheet1")
    Col = Application.Match("Country", Sheets("Sheet1").Rows(1), 0)     
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    lc = .Cells(1, Columns.Count).End(xlToRight).Column
    With .Cells (lr, 20).Copy Destination:= Sheets("Sheet2"). Column (“A:A”)
    End With
End With

3 answers

  • answered 2018-08-09 00:31 urdearboy

    1. Find header with text "Country" (I'm assuming your header is in Row 1)
    2. Once found, Copy the "Country" column and 19 columns to right
    3. Paste in Sheet2 A1

    Sub ColumnHunt()
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
    Dim pr As Range: Set pr = ThisWorkbook.Sheets("Sheet2").Range("A1") 'pr = Paste Range
    
    Dim lr As Long, Found As Range
    lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Set Found = ws.Cells(1, 1).EntireRow.Find("Country")
        If Not Found Is Nothing Then
            ws.Range(ws.Cells(1, Found.Column), ws.Cells(lr, Found.Column + 20)).Copy pr
        Else
            MsgBox "Country Column Not Found", vbCritical
        End If
    End Sub
    

  • answered 2018-08-09 00:35 MsAmeen

    I hope my following code (with some comments) will help

    Option Explicit
    
    Private Sub CommandButton1_Click()
    
    ' Get the last Row Number of your Data
    Dim myLastRow As Integer
    myLastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
    
    ' Get the Column Number of your Header Name = "Country"
    Dim myHeaderString As String
    Dim myHeaderCell As Range
    myHeaderString = "Country"
    Set myHeaderCell = Sheet1.Rows(1).Find(What:=myHeaderString, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    
    ' Be sure that we find that column, send an error message if NOT
    If Not myHeaderCell Is Nothing Then
        ' Get your Source Data Range
        Dim myColumnNo As Integer
        myColumnNo = myHeaderCell.Column
        Dim myRange As Range
        Set myRange = Sheet1.Range(Sheet1.Cells(1, myColumnNo), Sheet1.Cells(myLastRow, myColumnNo + 20))
    
        ' Copy The Source Data Range
        Sheet1.Activate
        myRange.Copy
    
        ' Past to the Target location
        Sheet2.Activate
        Sheet2.Cells(1, 1).Select
        Sheet2.Paste
    
    Else
            MsgBox "No Column Header found"
    End If
    
    End Sub
    

  • answered 2018-08-09 01:27 chris neilsen

    Here's your code, refactored and pointing out the issues in comments

    Sub Demo()
        Dim lr As Long
        'lc not used, left out
        Dim Col As Variant 'allow for possibility Country is not found
        With ThisWorkbook.Worksheets("Sheet1")
            ' Use the with block
            '   Sheets("Sheet1") may or may not be the same sheet as ThisWorkbook.Worksheets("Sheet1")
            'Col = Application.Match("Country", Sheets("Sheet1").Rows(1), 0)
            Col = Application.Match("Country", .Rows(1), 0)
    
            ' Allow for possibility Country is not found
            If Not IsError(Col) Then
                ' Rows.Count refers to the ActiveSheet,
                '   which may or may not have the same number of rows as ThisWorkbook.Worksheets("Sheet1")
                ' You are also assuming that Column A has at least the number of rows as your data.
                '   Is this what you want?
                'lr = .Cells(Rows.Count, 1).End(xlUp).Row
                lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    
                ' Specify the source range, starting at row 1, column containing Country
                '   then resize to the required size: lr rows, 21 columns
                ' Specify destination as top left cell, on the fully qualified sheet
                .Cells(1, Col).Resize(lr, 21).Copy Destination:=ThisWorkbook.Worksheets("Sheet2").Cells(1, 1)
    
                ' Alternative, if you don't need to copy formatting.
                'Dim r As Range
                'Set r = .Cells(1, Col).Resize(lr, 21)
                'ThisWorkbook.Worksheets("Sheet2").Cells(1, 1).Resize(r.Rows.Count, r.Columns.Count).Value _ 
                '  = r.Value
    
            End If
        End With
    End Sub