我正在尝试找到一种方法来搜索包含任意顺序的多个单词的单元格。 示例：在输入框中输入“搜索单词”。我现在想要搜索包含这三个单词的单元格，尽管它们不必按顺序排列或完全相邻。
希望你明白我的意思。我有这个代码，找到一个单词可以正常工作，但我被卡住了，并不知道如何解决这个问题。我知道有五个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
编辑： 如果在一个单元格中找到搜索到的所有单词，则应显示该行的超链接，但如果不是，则不应显示任何匹配项。所以我只想在这里寻找完整的比赛。
答案 0 :(得分：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