Please could you help a noob out?
If any of my search words ("transfer", "indicate" or "water") are within a cell in Column B on Sheet 1 (i.e. not an exact match, the cell may be = "national water" or "water-monthly" or "transfer to 1" or "TJ.indicate" and the cell should still be found) I would like to copy the whole row to Sheet 2. The data I am searching runs across 4 columns, and the search term would only be contained in Column B. I am using Excel 2016 or 2013 depending which computer I am working on.
I am wildly inexperienced and desperately need your help. I have cobbled together the following code, but I am aware that the .find terms don't correlate with how I am asking it to return the results, and don't run the searches on multiple terms.
Please could you help me fix this code? I would be so very grateful.
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 SubLoop a Find/FindNext within an outer loop through an array of search terms. Collect everything found into a union. Copy that union to the new location.
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