如何在第1行中搜索部分文本并将整列复制/粘贴到新工作表上

Question

I'm trying to search for partial text in row 1 of my spreadsheet. If a cell in row 1 contains that text, then I want to paste the entire column onto a new sheet in my workbook.

I receive a report every morning with 50+ columns but I am only concerned with about 5 of those columns. The problem is that the columns are not always in the same order, so I can't just write code to copy Column C every day.

Please see the below Sample Data. For example, I would like to search row 1 for any cells that contain "Tomato" and copy the entire column to a new sheet.

Sample Data

The only code I can find is below. However, it deals with copying a certain row if the text is found. Additionally, I'm not sure if the code is searching for a partial match or exact match.

Private Sub CommandButton1_Click()
   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer

   On Error GoTo Err_Execute

   'Start search in row 4
   LSearchRow = 4

   'Start copying data to row 2 in Sheet2 (row counter variable)
   LCopyToRow = 2

   While Len(Range("A" & CStr(LSearchRow)).Value) > 0

      'If value in column E = "Mail Box", copy entire row to Sheet2
      If InStr("A:AZ" & CStr(1)).Value = "Country" Then

         'Select row in Sheet1 to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy

         'Paste row into Sheet2 in next row
         Sheets("Sheet2").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste

         'Move counter to next row
         LCopyToRow = LCopyToRow + 1

         'Go back to Sheet1 to continue searching
         Sheets("Sheet1").Select

      End If



   Wend

   'Position on cell A3
   Application.CutCopyMode = False
   Range("A3").Select

   MsgBox "All matching data has been copied."

   Exit Sub

Err_Execute:
   MsgBox "An error occurred."
End Sub

Any help on this is greatly appreciated!

Answer 1

Try this:

Sub SearchFirstRowPasteEntireColumn()

    With Sheets("Sheet1")
        LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column
        ColumnCounter = 1
        For col = 1 To LastColumn
            If .Cells(1, col) Like "*SEARCH KEY HERE*" Then
                .Columns(col).Copy Destination:=Sheets("Sheet2").Columns(ColumnCounter)
                ColumnCounter = ColumnCounter + 1
            End If
        Next
    End With

End Sub

The macro search for a cell in the first row of Sheet1 containing "SEARCH KEY HERE", and if it finds anything, it copies to the first blank column of the Sheet2.

The macro keeps searching till the last Sheet1's column, and pasting to the next blank column of Sheet2

Answer 2

This should work and copies across a range by finding the last row of the column you're copying.

I've set up worksheet objects since I'm not sure what your sheets are called, and you can simply change the reference to them once at the start of the routine ( Sheet1 / Sheet2 ) and not worry about it in rest of code. Also added a variable for your Keywords, you might wish to change this easily by implementing a function or looping through a list of keywords in a range or something.

Sub eh()

Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim lCol1 As Long
Dim lCol2 As Long
Dim lRow As Long
Dim i As Long

Dim MY_TEXT_TO_MATCH As String

MY_TEXT_TO_MATCH = "tomato"

Set WS1 = ThisWorkbook.Worksheets("Sheet1")
Set WS2 = ThisWorkbook.Worksheets("Sheet2")

    lCol1 = WS1.Cells(1, WS1.Columns.Count).End(xlToLeft).Column

For i = 1 To lCol1
    If WS1.Cells(1, i).Value2 Like "*" & MY_TEXT_TO_MATCH & "*" Then
        lCol2 = WS2.Cells(1, WS2.Columns.Count).End(xlToLeft).Column + 1
        lRow = WS1.Cells(WS1.Rows.Count, i).End(xlUp).Row
        WS2.Range(Cells(1, lCol2).Address, Cells(lRow, lCol2).Address).Value = _
            WS1.Range(Cells(1, i).Address, Cells(lRow, i).Address).EntireColumn.Value
    End If
Next i

End Sub