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



## Brutusar (Dec 19, 2022)

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
```


----------



## Akuini (Dec 19, 2022)

Try this:


Brutusar said:


> However, I need to check each row for more than 100 different words, and the list of words is dynamic.


Put the list say in sheet3 col A



```
Sub Find_and_copy1()
 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
 Dim va, vb
 Dim i As Long
 Dim d As Object
 

 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
 
 *With Sheets("Sheet3")  'put the list here, amend as needed
    va = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))*
* End With*
 
        Set d = CreateObject("scripting.dictionary")
        d.CompareMode = vbTextCompare
        For i = 1 To UBound(va, 1)
            d(va(i, 1)) = Empty
        Next
 
        vb = sh1.Range("C1:C" & lastR1)
        For i = 2 To UBound(vb, 1)
           If d.Exists(vb(i, 1)) Then
               If rngCopy Is Nothing Then
                   Set rngCopy = sh1.Rows(i)
               Else
                   Set rngCopy = Union(rngCopy, sh1.Rows(i))
               End If
           End If
        Next
 
    If Not rngCopy Is Nothing Then
       rngCopy.Copy Destination:=sh2.Cells(lastR2, 1)
    End If
End Sub
```


----------



## Flashbond (Dec 19, 2022)

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
```


----------



## Brutusar (Dec 19, 2022)

Akuini said:


> Try this:
> 
> Put the list say in sheet3 col A
> 
> ...


Hi, thanks for your suggestion. It is working, but it only looks for the first word in the list, and does not continue to the next if the first is not found.


----------



## Brutusar (Dec 19, 2022)

Akuini said:


> Try this:
> 
> Put the list say in sheet3 col A
> 
> ...


Hi, thanks for the code.  It works, but only partially. If it find the first word in the list the code will stop. It will not test the second or third word if the first word is not found.


----------



## Akuini (Dec 19, 2022)

Brutusar said:


> Hi, thanks for your suggestion. It is working, but it only looks for the first word in the list, and does not continue to the next if the first is not found.


Not sure why. Where do you put the list?
It works on my side:
Example:

Book1CDE12HGriffin3AMalaki4GJermaine5MCayson6IZachary7CGabriel8KAriel9ZDominik10XAri11OErick12PAdrien13JZayn14BRoland15SGiovanni16UKamari17WKellen18TJedidiah19Emiliano20Sheet1

Result:
Book1ABCDE12AMalaki3CGabriel4KAriel5JZayn6Sheet2

The list:
Book1AB1A2J3Q4K5F6C7E8Sheet3


----------



## Brutusar (Dec 19, 2022)

Akuini said:


> Not sure why. Where do you put the list?
> It works on my side:
> Example:
> 
> ...


I put the list in Sheet3


Akuini said:


> Not sure why. Where do you put the list?
> It works on my side:
> Example:
> 
> ...


OK, I found the error, and that is on my side. In the column/cell where the code is looking for the words, there is sometimes a string with several words, and then it does not find it. It will only be found if it is the only word in the cell.


----------



## Akuini (Dec 19, 2022)

Brutusar said:


> OK, I found the error, and that is on my side. In the column/cell where the code is looking for the words, there is sometimes a string with several words, and then it does not find it. It will only be found if it is the only word in the cell.


So, is it working now? or you need to amend the code to suit?


----------



## Brutusar (Dec 19, 2022)

Akuini said:


> So, is it working now? or you need to amend the code to suit?


It is working in principle, but the code need to be changed to allow for searching for the "word" in a string with multiple words


----------



## Akuini (Dec 19, 2022)

Brutusar said:


> It is working in principle, but the code need to be changed to allow for searching for the "word" in a string with multiple words


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.


----------



## Brutusar (Dec 19, 2022)

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
```


----------



## Flashbond (Dec 19, 2022)

Why don't you try my code?


----------



## Brutusar (Dec 19, 2022)

Akuini said:


> 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:
> ...


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


----------



## Brutusar (Dec 19, 2022)

Flashbond said:


> This should be quite fast:
> 
> ```
> Public Sub FindAll()
> ...


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)


----------



## Flashbond (Dec 19, 2022)

Brutusar said:


> 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 (Dec 27, 2022)

Flashbond said:


> Where do you store the words?


They are in Sheet B, Col A


----------



## Flashbond (Dec 28, 2022)

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
```


----------

