搜索包含单词组合的单元格

Question

我正在尝试找到一种方法来搜索包含任意顺序的多个单词的单元格。 示例：在输入框中输入“搜索单词”。我现在想搜索包含这三个单词的单元格，尽管它们不必按那个顺序排列或根本不需要相邻。

希望你明白我的意思。我有这段代码，可以很好地找到一个单词，但我被卡住了，真的不知道如何解决这个问题。我知道使用五个 If 语句的解决方案不是很简洁，但它确实有效。

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

编辑： 如果在一个单元格中找到所有搜索的单词，则应显示指向该行的超链接，但如果不是，则不应匹配且不显示任何内容。所以我只在这里寻找完整的匹配。

Answer 1

.Find 方法对于复杂的搜索并不是很好。

这是一个使用正则表达式查看字符串的函数，并根据是否在字符串中找到所有三个单词返回 TRUE 或 FALSE。为了速度，我建议使用以下语法将要检查的单元格读取到变体数组中进行测试：

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

或者，最好是将范围限制为已使用范围的代码

遍历数组中的每一项，运行这个函数来查看单词是否存在。函数调用可能如下所示：

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

或

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

您可以搜索的字数最多可以是您的版本的最大参数数。

如果您愿意，并且这种方法适合您，您当然可以将此代码合并到您的宏中，而不是将其作为独立函数。这样做的好处是只需要更改 .Pattern，而不是在每次调用时创建和初始化一个正则表达式对象，这应该会使其运行得更快。

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