search包含单词组合的单元格

我试图find一种方法来search包含多个单词以任何顺序的单元格。 例如：在input框中input“search单词”。 我现在想要search一个包含这三个单词的单元格，尽pipe它们不必按顺序排列，或者彼此相邻。

希望你明白我的意思。 我有这个代码，这工作正常，find一个字，但我卡住，并没有真正有一个线索如何解决这个问题。 我知道五个解决schemeIf语句不是很整洁，但它的工作原理。

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 

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

Answer 1

.Find方法对于复杂的search不是很好。

这是一个使用正则expression式查看string的函数，并根据是否在string中find所有三个单词返回TRUE或FALSE。 我build议testing，为了速度，阅读你想检查到变体数组的单元格，使用语法如：

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

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

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

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

要么

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

您可以search的单词数量可以变化为您版本的最大参数数量。

如果你想，而且这种方法适合你，你当然可以将这个代码合并到你的macros中，而不是把它作为一个独立的函数。 这将有只需要改变.Pattern的优势，而不是创build和初始化每个调用的正则expression式对象，这应该使其运行速度更快。

 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