Copy an entire column after finding it by specific row

Question

I'm trying to find a column and copy its values after searching on specific row for value with inputbox.

What I try to achieve is to search on row 7, BUT in all columns for a specific text passed by user on an inputbox (lets say "test"). If test is found on row 7, column G (for example) i need the entire G column to be copyed to a new sheet or an existing one. Also, if test is found on G column and H column would be great to be copyed both but not one over another like paste both on A, shall be pasted on A and B.

What i have done so far:

Private Sub cancel_Click()
    Unload Me
End Sub

Private Sub ok_Click()

    Select Case True
    Case OptionButton1

      Call SearchByName

    Case OptionButton2
        Dim value2 As Variant
        value2 = InputBox("Find the column by characters.", "By characters")
        Unload Me
    Case Else
        MsgBox "You must select an option!"
    End Select

End Sub

Sub SearchByName()

    Dim value1 As Variant
    value1 = InputBox("Find the column by name.", "By name")
    'Unload Me

    Dim Found As Range, LastRow As Long
    Set Found = Rows(7).Find(what:=value1, LookIn:=xlValues, lookat:=xlWhole)
    If Found Is Nothing Then MsgBox "Column couldnt be copyed"

    LastRow = Cells(Rows.Count, Found.Column).End(xlUp).Row

    Dim Coloana As String
    Select Case Found.Column
        Case 1
        Coloana = "A"
        Case 2
        Coloana = "B"
        Case 3
        Coloana = "C"
        Case 4
        Coloana = "D"
        Case 5
        Coloana = "E"
        Case 6
        Coloana = "F"
        Case 7
        Coloana = "G"
        Case 8
        Coloana = "H"
        Case 9
        Coloana = "I"
        Case 10
        Coloana = "J"
        Case 11
        Coloana = "K"
        Case 13
        Coloana = "L"
        Case 14
        Coloana = "M"
        Case 15
        Coloana = "N"
        Case 16
        Coloana = "O"
        Case 17
        Coloana = "P"
    End Select

    Sheets("Sheet1").Range("A1:A" & LastRow).value = Sheets("DAT").Range(Coloana & 1 ":" & Coloana & LastRow).value

End Sub

Private Sub UserForm_Click()

End Sub

New code, also wrong... dunno why it doesnt check on Sheet1 for the next empty column :( it always return A column as empty)

Private Sub cancel_Click()
    Unload Me
End Sub

Private Sub ok_Click()

    Select Case True
    Case OptionButton1

      Call SearchByName

    Case OptionButton2
        Dim value2 As Variant
        value2 = InputBox("Find the column by characters.", "By characters")
        Unload Me
    Case Else
        MsgBox "You must select an option!"
    End Select

End Sub

Sub SearchByName()

    Dim value1 As Variant
    value1 = InputBox("Find the column by name.", "By name")
    Unload Me

    Dim Found As Range, LastRow As Long
    Dim ColoanaToAdd As String
    Dim emptyOne As String
    Dim destination As Worksheet
    Dim emptyColumn As String
    Dim var As String
    Dim Coloana As String

   'With Worksheets("DAT").Range("A1:W500")

    Set Found = Rows(7).Find(What:=value1, LookIn:=xlValues, LookAt:=xlWhole)
    'If Not Found Is Nothing Then
            'firstAddress = Found.Address
            'MsgBox "found" & firstAddress
        'Do

    LastRow = Cells(Rows.Count, Found.Column).End(xlUp).Row

    Select Case Found.Column
        Case 1
        Coloana = "A"
        Case 2
        Coloana = "B"
        Case 3
        Coloana = "C"
        Case 4
        Coloana = "D"
        Case 5
        Coloana = "E"
        Case 6
        Coloana = "F"
        Case 7
        Coloana = "G"
        Case 8
        Coloana = "H"
        Case 9
        Coloana = "I"
        Case 10
        Coloana = "J"
        Case 11
        Coloana = "K"
        Case 13
        Coloana = "L"
        Case 14
        Coloana = "M"
        Case 15
        Coloana = "N"
        Case 16
        Coloana = "O"
        Case 17
        Coloana = "P"
    End Select

    Set destination = Sheets("Sheet1")
    emptyColumn = destination.Cells(7, destination.Columns.Count).End(xlToLeft).Column
    MsgBox "empty coloana" & emptyColumn

    If emptyColumn > 1 Then
        emptyColumn = emptyColumn + 1
    End If

    MsgBox "empty coloana" & emptyColumn

    Select Case emptyColumn
        Case 1
        var = "A"
        Case 2
        var = "B"
        Case 3
        var = "C"
        Case 4
        var = "D"
        Case 5
        var = "E"
        Case 6
        var = "F"
        Case 7
        var = "G"
        Case 8
        var = "H"
        Case 9
        var = "I"
        Case 10
        var = "J"
        Case 11
        var = "K"
        Case 13
        var = "L"
        Case 14
        var = "M"
        Case 15
        var = "N"
        Case 16
        var = "O"
        Case 17
        var = "P"
    End Select

    emptyOne = var & 1 & ":" & var
    MsgBox emptyOne

    ColoanaToAdd = Coloana & 1 & ":" & Coloana
    MsgBox ColoanaToAdd

    Sheets("Sheet1").Range(emptyOne & LastRow).value = Sheets("DAT").Range(ColoanaToAdd & LastRow).value

    MsgBox "Entire column was copyed!"

    'Set Found = .FindNext(Found)
        'Loop While Not Found Is Nothing And Found.Address <> firstAddress
    'End If
   'End With

End Sub

Private Sub OptionButton1_Click()

End Sub

Private Sub UserForm_Click()

End Sub

Answer 1

How this works

• Asks user for the first value to search on row 7
• If found
  • It creates a new sheet
  • Remembers the value searched
  • Copies the column to the first column on the new sheet
  • Searches for the same value, on row 7, after the initial found value
    • If it finds another one it copies to the next available column on the new sheet
    • Repeats the search-and-copy to the last column on Sheet 1
  • Asks the user for the next value
    • If the user enters a value that was already processed
      • It confirms if it should copy the column(s) again
      • If it's confirmed, it will copy again
  • Repeats the process until the user cancels, or searches for an non-existent value

Code:

Option Explicit

Sub SearchByName()

    Const SRC_ROW   As Long = 7
    Const DELIM     As String = "||"

    Dim oldWS       As Worksheet
    Dim foundCel    As Range

    Set oldWS = Worksheets("Sheet1")

    Set foundCel = findColumn(oldWS.UsedRange.Rows(SRC_ROW))
    If foundCel Is Nothing Then
        MsgBox "Cancelled"
        Exit Sub
    Else
        Dim lastRow As Long
        Dim newWS   As Worksheet
        Dim selCol  As Long
        Dim lastCol As Long
        Dim done    As String
        Dim fndAdr  As String

        Set newWS = getNewWorkSheet("DAT")              'Selected Column(s)
        lastCol = 1
        done = DELIM
        Do
                done = done & foundCel.Value2 & DELIM   'remember all searched values
                selCol = foundCel.Column                'get found column
                lastRow = oldWS.Cells(oldWS.Rows.Count, foundCel.Column).End(xlUp).Row
                copyData oldWS, newWS, lastCol, lastRow, selCol

                fndAdr = foundCel.Address
                Do                                      'find next initial value on row
                    Set foundCel = oldWS.Rows(SRC_ROW).FindNext(foundCel.OFFSET(0, 1))
                    If Not foundCel Is Nothing And foundCel.Address <> fndAdr Then
                        selCol = foundCel.Column        'get found column
                        lastCol = lastCol + 1           'increment next col on new sheet
                        With oldWS                      'get last row
                            lastRow = .Cells(.Rows.Count, foundCel.Column).End(xlUp).Row
                        End With
                        copyData oldWS, newWS, lastCol, lastRow, selCol
                    End If
                Loop While Not foundCel Is Nothing And foundCel.Address <> fndAdr

                Set foundCel = findColumn(oldWS.Rows(SRC_ROW))  'ask for the next value
                If foundCel Is Nothing Then
                    Set foundCel = Nothing                      'user cancelled
                Else
                    'If already processed, confirm re-copy
                    If InStr(1, done, DELIM & foundCel & DELIM) > 0 Then
                        If MsgBox("Copy Again?", vbYesNo, "Processed") = vbNo Then
                            Set foundCel = Nothing
                            Exit Do
                        End If
                    End If
                    lastCol = lastCol + 1   'move to next search
                End If
        Loop While Not foundCel Is Nothing      'stops if canceled or value not found
        newWS.UsedRange.Columns.AutoFit         'resize copied cols for widest text
    End If
End Sub

---

Public Function getNewWorkSheet(ByVal wsName As String) As Worksheet

    Dim thisWS As Worksheet, activeWS As String

    Application.ScreenUpdating = False              'turn off display
    activeWS = ActiveSheet.Name                     'remember active sheet

    For Each thisWS In ActiveWorkbook.Worksheets    'look for pre-existing sheet
        If thisWS.Name = wsName Then
            Application.DisplayAlerts = False       'turn off sheet deletion warning
            thisWS.Delete                           'if found, delete it
            Application.DisplayAlerts = True
            Exit For
        End If
    Next

    Set thisWS = Worksheets.Add(Sheets(1))          'create a new sheet
    thisWS.Name = wsName                            'rename it

    Worksheets(activeWS).Activate                   'return to previous active sheet
    Application.ScreenUpdating = True
    Set getNewWorkSheet = thisWS
End Function

---

Public Function findColumn(ByVal srcRow As Range) As Range
    If Not srcRow Is Nothing Then
        Dim srcText As Variant
        srcText = InputBox("Find column by name", "By name")
        If Len(srcText) > 0 Then
            With srcRow
                Set findColumn = .Find(What:=srcText, _
                                       After:=.Cells(1, .Columns.Count), _
                                       SearchDirection:=xlPrevious, _
                                       LookIn:=xlFormulas, _
                                       LookAt:=xlWhole, _
                                       SearchOrder:=xlByRows)
            End With
        End If
    End If
End Function

---

Public Sub copyData(ByRef oldWS As Worksheet, _
                    ByRef newWS As Worksheet, _
                    ByVal lastCol As Long, _
                    ByVal lastRow As Long, _
                    ByVal selCol As Long)

    Dim col1    As Range
    Dim col2    As Range

    Set col1 = newWS.Range(newWS.Cells(1, lastCol), newWS.Cells(lastRow, lastCol))
    Set col2 = oldWS.Range(oldWS.Cells(1, selCol), oldWS.Cells(lastRow, selCol))

    col2.Copy col1

End Sub

---

Answer 2

Sub CopyMatchingColumns(inSheet As Worksheet, RowToSearch As Integer, ValueToSearchFor As String)
   Dim cell As Range
   Dim i As Integer
   Dim newsheet As Worksheet

   For i = 1 To inSheet.Columns.Count
      Set cell = inSheet.Cells(RowToSearch, i)
      If cell = ValueToSearchFor Then
         Set newsheet = Sheets.Add()
         cell.EntireColumn.Copy
         newsheet.Range("a1").Select
         newsheet.Paste
      End If
   Next i

End Sub

Example of how to run it

Sub test()
   CopyMatchingColumns ActiveSheet, 7, "Test"
End Sub

Good luck!