How to loop thru list of words and test these in RegEx in Excel VBA?

Question

I have a Excel workbook with two sheets, A and B.

Sheet A contains a lot of different unstructured data, sheet B, Col A, contains up to 100 strings (Each has 1-4 words), one per row.

I am using VBA to loop thru all rows in sheet A, find cells i a Col E in sheet A that contains the strings in Sheet B. If found, the row where it is found is copied to a Sheet C.

So far, all is good, the code I am using is working fine.

My problem is that the data in sheet B is static, and I wish to make it dynamic so strings can be added or deleted. The way I will do this is to populate sheet B from a database where the strings are being kept updated.

The code I am using will only test for the first word in sheet B, it will not move on to the next if the first is not found.

The code need to loop thru Sheet A, and for each row it need to loop thru the list of words in Sheet B, until it find the word, do the copy paste, and then move on to the next row in Sheet A.

The list of words in Sheet B will be much shorter if I could use RegEx when looking in Sheet A.

So my question is, I think that to do this I will need to save each string in sheet B as a variable, and then use this variable in the RegEx expression, and use that RegEx in the find?

Or does anyone has a different idea, and maybe point me in the right direction on how to write the missing code?

The code I am using now is:

Sub Find()
 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("SheetC")
 
 lastR1 = sh1.Range("E" & Rows.Count).End(xlUp).Row
 lastR2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
 
 With Sheets("SheetB")  'this is where the list is
    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("E1:E" & 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

Answer 1

Option Explicit

Sub FindString()

    Dim wsA As Worksheet, wsB As Worksheet, wsC As Worksheet
    Dim lastA As Long, lastB As Long, lastC As Long
    Dim va, vb, rngCopy As Range, n As Long, i As Long
   
    With ThisWorkbook
        Set wsA = .Sheets("SheetA")
        Set wsB = .Sheets("SheetB")
        Set wsC = .Sheets("SheetC")
    End With
     
    lastA = wsA.Range("E" & Rows.Count).End(xlUp).Row
    lastB = wsB.Range("A" & Rows.Count).End(xlUp).Row
    lastC = wsC.Range("A" & Rows.Count).End(xlUp).Row + 1
    
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = vbTextCompare
    
    'this is where the list is
    vb = wsB.Range("A1:A" & lastB).Value2
    For i = 1 To lastB
        d(vb(i, 1)) = Empty
    Next
    
    ' build regex pattern from dictionary keys
    Dim Regex As Object, sPattern As String
    Set Regex = CreateObject("vbscript.regexp")
    sPattern = Join(d.keys, "|")
    'Debug.Print sPattern
    
    With Regex
        .Global = False
        .MultiLine = False
        .IgnoreCase = True
        .Pattern = sPattern
    End With
    
    ' search sheetA
    va = wsA.Range("E1:E" & lastA)
    For i = 2 To lastA
       If Regex.test(va(i, 1)) Then
           If rngCopy Is Nothing Then
               Set rngCopy = wsA.Rows(i)
           Else
               Set rngCopy = Union(rngCopy, wsA.Rows(i))
           End If
           n = n + 1 ' count matches
       End If
    Next

    ' result
    If rngCopy Is Nothing Then
        MsgBox "No rows found", vbExclamation
    Else
        rngCopy.Copy Destination:=wsC.Cells(lastC, 1)
        MsgBox n & " rows found", vbInformation
    End If
    
End Sub