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.

VBA Code:

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

Rich (BB code):

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

Legacy 143009 · Dec 19, 2022

This should be quite fast:

VBA Code:

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

Rich (BB code):

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

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

Rich (BB code):

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

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:

Book1

C

D

E

1

2

H

Griffin

3

A

Malaki

4

G

Jermaine

5

M

Cayson

6

I

Zachary

7

C

Gabriel

8

K

Ariel

9

Z

Dominik

10

X

Ari

11

O

Erick

12

P

Adrien

13

J

Zayn

14

B

Roland

15

S

Giovanni

16

U

Kamari

17

W

Kellen

18

T

Jedidiah

19

Emiliano

20

Sheet1

Result:

Book1

A

B

C

D

E

1

2

A

Malaki

3

C

Gabriel

4

K

Ariel

5

J

Zayn

6

Sheet2

The list:

Book1

A

B

1

A

2

J

3

Q

4

K

5

F

6

C

7

E

8

Sheet3

Brutusar · Dec 19, 2022

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

Book1
C D E
1
2 H Griffin
3 A Malaki
4 G Jermaine
5 M Cayson
6 I Zachary
7 C Gabriel
8 K Ariel
9 Z Dominik
10 X Ari
11 O Erick
12 P Adrien
13 J Zayn
14 B Roland
15 S Giovanni
16 U Kamari
17 W Kellen
18 T Jedidiah
19 Emiliano
20
Sheet1

Result:

Book1
A B C D E
1
2 A Malaki
3 C Gabriel
4 K Ariel
5 J Zayn
6
Sheet2

The list:

Book1
A B
1 A
2 J
3 Q
4 K
5 F
6 C
7 E
8
Sheet3

I put the list in Sheet3

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

Book1
C D E
1
2 H Griffin
3 A Malaki
4 G Jermaine
5 M Cayson
6 I Zachary
7 C Gabriel
8 K Ariel
9 Z Dominik
10 X Ari
11 O Erick
12 P Adrien
13 J Zayn
14 B Roland
15 S Giovanni
16 U Kamari
17 W Kellen
18 T Jedidiah
19 Emiliano
20
Sheet1

Result:

Book1
A B C D E
1
2 A Malaki
3 C Gabriel
4 K Ariel
5 J Zayn
6
Sheet2

The list:

Book1
A B
1 A
2 J
3 Q
4 K
5 F
6 C
7 E
8
Sheet3

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.

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

Brutusar

Board Regular

Excel Facts

Akuini

Well-known Member

Legacy 143009

Guest

Brutusar

Board Regular

Brutusar

Board Regular

Akuini

Well-known Member

Brutusar

Board Regular

Akuini

Well-known Member

Brutusar

Board Regular

Akuini

Well-known Member

Similar threads

Forum statistics

Share this page

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

Board Regular

Excel Facts

Well-known Member

Legacy 143009

Guest

Board Regular

Board Regular

Well-known Member

Board Regular

Well-known Member

Board Regular

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock