CODEWITHSUNDEEP
vbaexcel
Souza Saulo
Souza Saulo

Reputation: 61

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

Upvotes: 0

Views: 1316

Answers (3)

MsAmeen
MsAmeen

Reputation: 96

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

Upvotes: -1

chris neilsen
chris neilsen

Reputation: 53126

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

Upvotes: 2

urdearboy
urdearboy

Reputation: 14590

  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

Upvotes: 1

Related Questions