Search code examples
excelvba

VBA Set Variable Equal to Column based on name in Row

Looking to see if I can search Row 2 for the title 'Country' and then use that whole column value later to select the row, copy it and paste it to a new sheet.

So Far I have the following, but I can't seem to get this to work.

Sub Extract_Country()

Dim CountryInput As Variant
Dim CountryCol As Range
Dim i As Long
Dim CopyRange As Range
Dim test As Single

CountryInput = Range("CountryInput")

startrow = 1
endrow = 2000
startcol = 1
number_of_columns = 200

'Take Away Merge
Rows("1:1").Select
With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Interior.ColorIndex = xlNone
    End With


Set CountryCol = Range("2:2").Find("Country")


'Copy Rows that Equal CountryInput
For i = 1 To endrow
    test = Cells(i, CountryCol)  'look in every row
    compare = StrComp(test, CountryInput, vbTextCompare)  'compare to the look up value
    
    If compare = 0 Then
        CopyRange = Union(CopyRange, ActiveRow)
    End If
    
Next i


'Create New Sheet
Sheets.Add After:=ActiveSheet.Name = CountryInput & "1"

Any help much appreciated.

I keep tweaking but basically can't select the correct column as something is off with my reference.

Solution
    • Your code is close to finish. But you need to fix some syntax errors.
    Option Explicit
Sub Extract_Country()
    Dim CountryInput As String
    Dim CountryCol As Range
    Dim CopyRange As Range, ShtName As String
    Dim oSht As Worksheet, i As Long, desSht As Worksheet
    Const HEADER_ROW = 2
    Const END_ROW = 2000
    Set oSht = Sheets("Sheet1")  ' modify as needed
    CountryInput = oSht.Range("CountryInput")
    'Take Away Merge
    With oSht.Rows(1)
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Interior.ColorIndex = xlNone
    End With
    Set CountryCol = oSht.Rows(HEADER_ROW).Find("Country", LookIn:=xlValues, lookAt:=xlWhole)
    If Not CountryCol Is Nothing Then
        'Copy Rows that Equal CountryInput
        Dim c As Range, compare As Long
        For i = HEADER_ROW + 1 To END_ROW
            Set c = oSht.Cells(i, CountryCol.Column)  'look in every row
            compare = StrComp(CountryInput, c.Value, vbTextCompare)  'compare to the look up value
            If compare = 0 Then
                If CopyRange Is Nothing Then
                    Set CopyRange = c
                Else
                    Set CopyRange = Application.Union(CopyRange, c)
                End If
            End If
        Next i
        If Not CopyRange Is Nothing Then
            ShtName = CountryInput & "1"
            On Error Resume Next
            Set desSht = Sheets(ShtName)
            On Error GoTo 0
            If desSht Is Nothing Then
                Set desSht = Sheets.Add
                desSht.Name = ShtName
            Else
                desSht.Cells.Clear
            End If
            CopyRange.EntireRow.Copy desSht.Range("A1")
        End If
    End If
End Sub

    enter image description here

    • AutoFitler is a good option (@Siddharth Rout posted a comment first)
    Option Explicit
Sub Extract_Country()
    Dim CountryInput As String
    Dim CountryCol As Range
    Dim CopyRange As Range, ShtName As String
    Dim oSht As Worksheet, i As Long, desSht As Worksheet
    Const HEADER_ROW = 2
    Set oSht = Sheets("Sheet1")  ' modify as needed
    CountryInput = oSht.Range("CountryInput")
    'Take Away Merge
    With oSht.Rows(1)
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Interior.ColorIndex = xlNone
    End With
    Set CountryCol = oSht.Rows(HEADER_ROW).Find("Country", LookIn:=xlValues, lookAt:=xlWhole)
    With oSht.Range("A2").CurrentRegion ' modify as needed
        .AutoFilter Field:=CountryCol.Column, Criteria1:=CountryInput
        On Error Resume Next
        Set CopyRange = .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If CopyRange.Rows.Count > 1 Then
            ShtName = CountryInput & "1"
            On Error Resume Next
            Set desSht = Sheets(ShtName)
            On Error GoTo 0
            If desSht Is Nothing Then
                Set desSht = Sheets.Add
                desSht.Name = ShtName
            Else
                desSht.Cells.Clear
            End If
            CopyRange.Copy desSht.Range("A1")
            ' remover header if needed
            ' desht.Rows(1).Delete
        End If
        .AutoFilter
    End With
End Sub