Best way to use "Find" when having many words to test

[Brutusar]

Hi, I need to loop thru a range in Active sheet, (Column E from first to last row) and find one of many different possible words. If a word is found, the hole row will be copied to Sheet2.
So far no problems.

However, I need to check each row for more than 100 different words, and the list of words is dynamic. Words will be deleted, and other added. One way to do this is to read the words into an array every time the code is running, and then loop thru that array for each row.

It will rarely be more than 500 rows, but with 100-150 words to check for it will take a little time. So far I have just been searching for 15-20 words, all static, but the needs have changed.

Does anyone has any suggestion to the best way of doing this?

I have up to now used the code below, but it has become impractical now.

Sub Find_and_copy ()
 Dim sh1 As Worksheet, sh2 As Worksheet, rng As Range, cel As Range
 Dim rngCopy As Range, lastR1 As Long, lastR2 As Long
 Dim strSearch1 As String, strSearch2 As String
 
 strSearch1 = "teststring1"
 strSearch2 = "teststring2"
 Set sh1 = ActiveSheet         
 Set sh2 = Worksheets("Sheet2")
 lastR1 = sh1.Range("C" & Rows.count).End(xlUp).Row
 lastR2 = sh2.Range("A" & Rows.count).End(xlUp).Row + 1
 
 Set rng = sh1.Range("C2:C" & lastR1)
 For Each cel In rng.cells
    If cel.Value = strSearch Or cel.Value = strSearch2 Then
        If rngCopy Is Nothing Then
            Set rngCopy = sh1.Rows(cel.Row)
        Else
            Set rngCopy = Union(rngCopy, sh1.Rows(cel.Row))
        End If
    End If
 Next
 If Not rngCopy Is Nothing Then
    rngCopy.Copy Destination:=sh2.cells(lastR2, 1)
 End If
End Sub

 

[Legacy 143009]

Why don't you try my code?

 

[Brutusar]

That's doable, but depends on your data, searching for partial match could have this problem:
Example:
Word to find: car
Find in these 2 sentences:
1. I have a car,
2. This is a card.

You probably just want to match "car" in the first sentence, but it would also match "car" (in "card") in the second sentence.
Could your data have this kind of problem?
If yes, then we need to use regex.

It is possible that situation could happen yes, but not likely. It will most likely be separate words as in a sentence

 

[Brutusar]

This should be quite fast:

Public Sub FindAll()
    Dim rv As Range, f As Range, rng As Range, sh1 As Range, sh2 As Range
    Dim addr As String, strSearch1 As String, strSearch2 As String
    Dim lastR1 As Long, lastR2 As Long

    strSearch1 = "teststring1"
    strSearch2 = "teststring2"
    Set sh1 = ActiveSheet
    Set sh2 = Worksheets("Sheet2")
    lastR1 = sh1.Range("C" & Rows.Count).End(xlUp).Row
    lastR2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
    Set rng = sh1.Range("C2:C" & lastR1)
 
    Set f = rng.Find(what:=strSearch1, after:=rng.Cells(rng.Cells.Count), _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False)
    If Not f Is Nothing Then addr = f.Address()
    Do Until f Is Nothing
        If rv Is Nothing Then
            Set rv = f.EntireRow
        Else
            Set rv = Union(rv, f.EntireRow)
        End If
        Set f = rng.FindNext(after:=f)
        If f.Address() = addr Then Exit Do
    Loop
    Set f = rng.Find(what:=strSearch2, after:=rng.Cells(rng.Cells.Count), _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False)
    If Not f Is Nothing Then addr = f.Address()
    Do Until f Is Nothing
        If rv Is Nothing Then
            Set rv = f.EntireRow
        Else
            Set rv = Union(rv, f.EntireRow)
        End If
        Set f = rng.FindNext(after:=f)
        If f.Address() = addr Then Exit Do
    Loop

  If Not rv Is Nothing Then
    rv.Copy
    sh2.Cells(lastR2, 1).Insert Shift:=xlDown
  End If
 
End Sub

Hi, I did try it, the problem is that it is static when it comes to the words that needs to be tested. (teststring1 and teststring2) It works with a few words, but not when it is maybe 100, and these words changes from time to time. (Unless I have misunderstood something in your code)

 

[Legacy 143009]

Hi, I did try it, the problem is that it is static when it comes to the words that needs to be tested. (teststring1 and teststring2) It works with a few words, but not when it is maybe 100, and these words changes from time to time. (Unless I have misunderstood something in your code)

Where do you store the words?

 

[Brutusar]

Where do you store the words?

They are in Sheet B, Col A

 

[Legacy 143009]

How about this?

Public Sub FindAll()
  Dim rv As Range, f As Range, rng As Range, sh1 As Range, sh2 As Range
  Dim addr As String, strSearch1 As String, strSearch2 As String
  Dim lRow As Long
  Dim lastR1 As Long, lastR2 As Long

  lRow = Worksheets("Sheet B").Cells(Rows.Count, 1).End(xlUp).Row
  Set sh1 = ActiveSheet
  Set sh2 = Worksheets("Sheet2")
  lastR1 = sh1.Range("C" & Rows.Count).End(xlUp).Row
  lastR2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
  Set rng = sh1.Range("C2:C" & lastR1)

  With Worksheets("Sheet B")
    For i = 1 to lRow
      Set f = rng.Find(what:=.Cells(i, 1).Value, after:=rng.Cells(rng.Cells.Count), _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False)
    If Not f Is Nothing Then addr = f.Address()
      Do Until f Is Nothing
        If rv Is Nothing Then
          Set rv = f.EntireRow
        Else
          Set rv = Union(rv, f.EntireRow)
        End If
        Set f = rng.FindNext(after:=f)
        If f.Address() = addr Then Exit Do
      Loop
    End With
  Next

  If Not rv Is Nothing Then
    rv.Copy
    sh2.Cells(lastR2, 1).Insert Shift:=xlDown
  End If
End Sub