Search for cell containing combination of words

Question

I am trying to find a way to search for a cell that contains multiple words in any order. Example: In the input box I enter "search for words". I now want search for a cell containing these three words, although they don't have to come in that order or next to each other at all.

Hope you understand what I mean. I have this code, wich works fine to find one word, but I'm stuck and don't really have a clue how to solve this. I know the solution with five If statements isn't really neat but it works.

Sub Set_Hyper()

 '   Object variables
Dim wks As Excel.Worksheet
Dim rCell As Excel.Range
Dim fFirst As String
 '   {i} will act as our counter
Dim i As Long

Dim MyVal As String
 '   Search phrase
MyVal = ActiveSheet.Range("D9")

Application.ScreenUpdating = False
Application.DisplayAlerts = False

i = 19
 '       Begin looping:
 '       We are checking all the Worksheets in the Workbook
For Each wks In ActiveWorkbook.Worksheets
     If wks.Name <> "Start" Then

     '       We are checking all cells, we don't need the SpecialCells method
     '       the Find method is fast enough
        With wks.Range("A:E")
         '           Using the find method is faster:
         '           Here we are checking column "A" that only have {myVal} explicitly

            Set rCell = .Find(MyVal, , , xlPart, xlByColumns, xlNext, False)
         '           If something is found, then we keep going
            If Not rCell Is Nothing Then
             '               Store the first address
                fFirst = rCell.Address

                ' Where is the answer
                Do

                    If rCell.Column() = 1 Then
                    ' Link to each cell with an occurence of {MyVal}
                    rCell.Hyperlinks.Add Cells(i, 4), "", "'" & wks.Name & "'!" & rCell.Address, TextToDisplay:=rCell.Value
                    rCell.Offset(0, 1).Copy Destination:=Cells(i, 5)
                    rCell.Offset(0, 2).Copy Destination:=Cells(i, 6)
                    rCell.Offset(0, 3).Copy Destination:=Cells(i, 7)
                    rCell.Offset(0, 4).Copy Destination:=Cells(i, 8)
                 '   wks.Range("B" & rCell.Row & ":R" & rCell.Row).Copy Destination:=Cells(i, 5)
                    Set rCell = .FindNext(rCell)
                    i = i + 1 'Increment our counter

                    End If

                    If rCell.Column() = 2 Then
                    ' Link to each cell with an occurence of {MyVal}
                    rCell.Hyperlinks.Add Cells(i, 4), "", "'" & wks.Name & "'!" & rCell.Address, TextToDisplay:=rCell.Offset(0, -1).Value
                    rCell.Copy Destination:=Cells(i, 5)
                    rCell.Offset(0, 1).Copy Destination:=Cells(i, 6)
                    rCell.Offset(0, 2).Copy Destination:=Cells(i, 7)
                    rCell.Offset(0, 3).Copy Destination:=Cells(i, 8)
                 '   wks.Range("B" & rCell.Row & ":R" & rCell.Row).Copy Destination:=Cells(i, 5)
                    Set rCell = .FindNext(rCell)
                    i = i + 1 'Increment our counter

                    End If

                    If rCell.Column() = 3 Then
                    ' Link to each cell with an occurence of {MyVal}
                    rCell.Hyperlinks.Add Cells(i, 4), "", "'" & wks.Name & "'!" & rCell.Address, TextToDisplay:=rCell.Offset(0, -2).Value
                    rCell.Offset(0, -1).Copy Destination:=Cells(i, 5)
                    rCell.Copy Destination:=Cells(i, 6)
                    rCell.Offset(0, 1).Copy Destination:=Cells(i, 7)
                    rCell.Offset(0, 2).Copy Destination:=Cells(i, 8)
                 '   wks.Range("B" & rCell.Row & ":R" & rCell.Row).Copy Destination:=Cells(i, 5)
                    Set rCell = .FindNext(rCell)
                    i = i + 1 'Increment our counter

                    End If

                    If rCell.Column() = 4 Then
                    ' Link to each cell with an occurence of {MyVal}
                    rCell.Hyperlinks.Add Cells(i, 4), "", "'" & wks.Name & "'!" & rCell.Address, TextToDisplay:=rCell.Offset(0, -3).Value
                    rCell.Offset(0, -2).Copy Destination:=Cells(i, 5)
                    rCell.Offset(0, -1).Copy Destination:=Cells(i, 6)
                    rCell.Copy Destination:=Cells(i, 7)
                    rCell.Offset(0, 1).Copy Destination:=Cells(i, 8)
                 '   wks.Range("B" & rCell.Row & ":R" & rCell.Row).Copy Destination:=Cells(i, 5)
                    Set rCell = .FindNext(rCell)
                    i = i + 1 'Increment our counter

                    End If

                    If rCell.Column() = 5 Then
                    ' Link to each cell with an occurence of {MyVal}
                    rCell.Hyperlinks.Add Cells(i, 4), "", "'" & wks.Name & "'!" & rCell.Address, TextToDisplay:=rCell.Offset(0, -4).Value
                    rCell.Offset(0, -3).Copy Destination:=Cells(i, 5)
                    rCell.Offset(0, -2).Copy Destination:=Cells(i, 6)
                    rCell.Offset(0, -1).Copy Destination:=Cells(i, 7)
                    rCell.Copy Destination:=Cells(i, 8)
                 '   wks.Range("B" & rCell.Row & ":R" & rCell.Row).Copy Destination:=Cells(i, 5)
                    Set rCell = .FindNext(rCell)
                    i = i + 1 'Increment our counter

                    End If

                    Loop While Not rCell Is Nothing And rCell.Address <> fFirst
            End If
        End With
     End If
Next wks
 '   Explicitly clear memory
Set rCell = Nothing
    '   Reset application settings
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

EDIT: If all words searched for are found in one cell, the hyperlink to that row should be displayed, but if not there should be no match and nothing displayed. So I'm only looking for complete matches here.

Answer 1

The .Find method is not real good with complicated searches.

Here is a function using Regular Expressions to look at a string, and return TRUE or FALSE depending on whether or not all three words are found in the string. I would suggest testing, for speed, reading the cells you wish to check into a variant array, using a syntax such as:

V=wks.range("A:E")

or, preferably, code that limits the range to just the used range

Iterating through each item in the array, running this function to see if the words are present. The function call might look like:

IsTrue = Function FindMultWords(StringToSearch,"search","for","words")  

or

IsTrue = Function FindMultWords(Your_Array(I),"search","for","words")

The number of words you can search for can vary up to the maximum number of arguments for your version.

If you want, and this approach works for you, you could certainly incorporate this code into your macro, instead of having it as a standalone function. That would have the advantage of only needing to change .Pattern, instead of creating and initializing a regex object on each call, which should make it run faster.

Option Explicit
Function FindMultWords(sSearchString As String, ParamArray aWordList()) As Boolean
    Dim RE As Object
    Dim S As String
    Const sP1 As String = "(?=[\s\S]*\b"
    Const sP2 As String = "\b)"
    Const sP3 As String = "[\s\S]+"

    Dim I As Long
Set RE = CreateObject("vbscript.regexp")
With RE
    .Global = True
    .MultiLine = True
    .ignorecase = True

    S = "^"
    For I = LBound(aWordList) To UBound(aWordList)
        S = S & sP1 & aWordList(I) & sP2
    Next I
    S = S & sP3
    .Pattern = S

    FindMultWords = .test(sSearchString)
End With
End Function