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

Question

请您帮忙一个菜鸟吗？

如果我的任何搜索字词（“转让”，“指示”或“水”）在表1的B列中的某个单元格内（即不完全匹配），则该单元格可能是“国家水量”或“每月水量” ”或“转移到1”或“ TJ.indicate”，仍应找到该单元格）我想将整行复制到工作表2。我要搜索的数据跨越4列，并且搜索项只能是我正在使用Excel 2016或2013，具体取决于我在使用的计算机。

我没有经验，非常需要您的帮助。 我将以下代码拼凑在一起，但是我知道.find术语与我要求它返回结果的方式不相关，并且不要对多个术语进行搜索。

请您能帮我解决此代码吗？ 我将非常感谢。

 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

通过一组搜索项在外部循环中循环查找/查找下一个。 将发现的所有内容收集到一个工会中。 将该联合复制到新位置。

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