Excel VBA: используйте .Find для идентификации содержимого ячейки и копирования строки на новую вкладку (несколько поисковых запросов)

Question

Пожалуйста, не могли бы вы помочь новичку?

Если какое-либо из моих поисковых слов («перевод», «указать» или «вода») находится в пределах ячейки в столбце B на листе 1 (т. Е. Не точное совпадение, ячейка может быть = «национальная вода»)."или" water-month "или" переход к 1 "или" TJ.indicate ", и ячейка все еще должна быть найдена). Я хотел бы скопировать всю строку на лист 2. Данные, которые я ищу, проходят через 4 столбца, иусловие поиска будет содержаться только в столбце B. Я использую 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

Цикл 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