Excel VBA：使用 .Find 识别单元格内容并将行复制到新选项卡（多个搜索词）

Question

你能帮个小白吗？

如果我的任何搜索词（"transfer"、"indicate" 或 "water"）位于 Sheet 1 上 B 列的单元格内（即不完全匹配，该单元格可能是 = "national water" 或 "water-monthly" 或 "transfer to 1" 或 "TJ.indicate" 并且仍应找到该单元格）我想将整行复制到 Sheet 2. 我在 4 列中搜索运行s 的数据，搜索词只包含在 B 列中。我使用的是 Excel 2016 或 2013，具体取决于我正在使用的计算机。

我非常缺乏经验，迫切需要您的帮助。我拼凑了以下代码，但我知道 .find 术语与我要求它 return 结果的方式不相关，并且不运行多个术语的搜索.

你能帮我修复这段代码吗？我将不胜感激。

Option Explicit

Sub SearchForString()

   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 Sheet3 (row counter variable)
   LCopyToRow = 2

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

      'If value in column C contains "Transfer", copy entire row to Sheet2
      Set cell = Range("C:C").Find("Transfer", After:=Range("C2"), LookIn:=xlValues, Lookat:=xlPart, MatchCase:=False)

         '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

      LSearchRow = LSearchRow + 1

   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

在搜索词数组的外循环中循环 Find/FindNext。将找到的所有东西收集到一个联合中。将该联合复制到新位置。

Option Explicit

Sub SearchForString()

    Dim a As Long, arr As Variant, fnd As Range, cpy As Range, addr as string

    On Error GoTo Err_Execute

    'populate the array for the outer loop
    arr = Array("transfer", "indicate", "water")

    With Worksheets("sheet1")

        'outer loop through the array
        For a = LBound(arr) To UBound(arr)
            'locate first instance
            Set fnd = .Columns("B").Find(what:=arr(a), LookIn:=xlFormulas, LookAt:=xlPart, _
                                         SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                         MatchCase:=False, SearchFormat:=False)
            If Not fnd Is Nothing Then
               'record address of first find
                addr = fnd.Address
                'seed the cpy range object
                If cpy Is Nothing Then Set cpy = fnd.EntireRow
                Do
                    'build union
                    Set cpy = Union(cpy, fnd.EntireRow)

                    'look for another
                    Set fnd = .Columns("B").FindNext(after:=fnd)

                'keep finding new matches until it loops back to the first
                Loop Until fnd.Address = addr
            End If
        Next a

    End With

    With Worksheets("sheet2")
        'one stop copy & paste operation
        cpy.Copy Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
    End With

    MsgBox "All matching data has been copied."

    Exit Sub

Err_Execute:
    Debug.Print Now & " " & Err.Number & " - " & Err.Description

End Sub

Excel VBA：使用 .Find 识别单元格内容并将行复制到新选项卡（多个搜索词）

Excel VBA: Use .Find to identify cell contents and copy row to a new tab (multiple search terms)

excel

vba

copy-paste

find