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

Question

我正在尝试在电子表格的第1行中搜索部分文本。 如果第1行中的单元格包含该文本，那么我想将整列粘贴到工作簿中的新工作表上。

我每天早上收到一份包含50多个专栏的报告，但我只关心其中的5列。 问题在于列的顺序并不总是相同，因此我不能只写代码每天复制列C。

请参见下面的示例数据。 例如，我想在第1行中搜索包含“西红柿”的所有单元格，然后将整列复制到新的工作表中。

样本数据

我可以找到的唯一代码如下。 但是，如果找到了文本，它将处理复制特定的行。 另外，我不确定代码是否在搜索部分匹配或完全匹配。

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

在此方面的任何帮助将不胜感激！

Answer 1

尝试这个：

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

宏在Sheet1的第一行中搜索包含“ SEARCH KEY HERE”的单元格，如果找到任何内容，它将复制到Sheet2的第一空白列。

宏会一直搜索到Sheet1的最后一列，然后粘贴到Sheet2的下一个空白列

Answer 2

通过找到要复制的列的最后一行，这应该可以正常工作并在一定范围内进行复制。

我已经建立了工作表对象，因为我不确定您的工作表是什么，您可以在例程开始时（ Sheet1 / Sheet2 ）更改一次对它们的引用，而不必担心其余的代码。 另外，还为您的关键字添加了一个变量，您可能希望通过实现函数或循环浏览某个范围内或某个范围内的关键字列表来轻松更改此设置。

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