搜索包含单词组合的单元格 [英] Search for cell containing combination of words
问题描述
我正在尝试寻找一种以任何顺序搜索包含多个单词的单元格的方法。
示例：在输入框中，我输入搜索单词。我现在想要搜索一个包含这三个单词的单元格，尽管它们不一定要按照这个顺序或彼此相邻。
希望你明白什么我的意思是。我有这个代码，可以找到一个字，但我被卡住了，真的不知道如何解决这个问题。我知道解决方案有五个If语句不是很整齐，但它的工作。
Sub Set_Hyper（）
'对象变量
Dim wks As Excel.Worksheet
Dim rCell As Excel.Range
Dim fFirst As String
'{i}将作为我们的计数器
Dim i As Long
Dim MyVal As String
'搜索短语
MyVal = ActiveSheet.Range（D9）
Application.ScreenUpdating = False
Application.DisplayAlerts = False
i = 19
'开始循环：
'我们正在检查工作簿中的所有工作表
对于每个wks In ActiveWorkbook.Worksheets
如果wks.Name<> 开始然后
'我们正在检查所有单元格，我们不需要SpecialCells方法
'Find方法足够快
使用wks.Range（A： E）
'使用find方法更快：
'这里我们检查只显示{myVal}的列A
设置rCell = .Find（MyVal ，，，xlPart，xlByColumns，xlNext，False）
'如果找到某个东西，那么我们继续去
如果不是rCell是没有，然后
'存储第一个地址
fFirst = rCell.Address
'答案在哪里
做
如果rCell.Column（）= 1然后
'链接到每个单元格发生{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：=单元格（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）
设置rCell =。 FindNext（rCell）
i = i + 1'增加我们的计数器
如果
如果rCell.Column（）= 2然后
'链接到每个单元格发生{MyVal}
rCell.Hyperlinks.Add Cells（i，4），，'& wks.Name& ！ &安培; rCell.Address，TextToDisplay：= rCell.Offset（0，-1）.Value
rCell.Copy目的地：= Cells（i，5）
rCell.Offset（0，1）.Copy目的地： = Cells（i，6）
rCell.Offset（0,2）.Copy Destination：= Cells（i，7）
rCell.Offset（0，3）.Copy Destination：= Cells ，8）
'wks.Range（B& rCell.Row&：R& rCell.Row）.Copy Destination：= Cells（i，5）
Set rCell = FindNext（rCell）
i = i + 1'增加我们的计数器
如果
如果rCell.Column（）= 3然后
'链接发送到每个单元格{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目的地：= 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'增加我们的计数器
如果
如果rCell.Column（）= 4然后
'链接到每个单元格，发生{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目的地：= 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'增加我们的计数器
如果
如果rCell.Column（）= 5然后
'链接到每个单元格，发生{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：=单元格（i，8）
'wks.Range（B& rCell.Row&：R& rCell.Row）.Copy Destination：= Cells（i，5）
设置rCell = .FindNext（rCell）
i = i + 1'增加我们的计数器
结束如果
循环，而不是rCell是没有和rCell.Address< > fFirst
如果
结束
结束If
下一个wks
'显式清除内存
设置rCell = Nothing
'重置应用程序设置
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
EDIT：
如果在一个单元格中找到所有搜索的单词，则应显示该行的超链接，但如果不是，则应该不显示任何匹配项。所以我只想在这里找到完整的比赛。
.Find方法对于复杂的搜索来说不是很好。 p>
这里是使用正则表达式查看字符串的函数，并返回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
函数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
设置RE = CreateObject（vbscript.regexp）
用RE
.Global = True
.MultiLine = True
.ignorecase = True
S =^
对于I = LBound（aWordList）到UBound（aWordList）
S = S& sP1& aWordList（I）& sP2
下一个I
S = S& sP3
.Pattern = S
FindMultWords = .test（sSearchString）
结束
结束功能
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.
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
这篇关于搜索包含单词组合的单元格的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
