问题描述
是否有一种方法可以按单词划分搜索并比较Excel中的部分匹配项？
例如， 如果我的表包含：
reinterpret_cast<B*>example test phrase | result1
phrase test two | result2
excluded phrase | result3
这仅返回结果1，而不返回结果2，因为它正在寻找整个短语，仅按照键入顺序进行搜索。
输入搜索字符串“测试短语”后，我需要返回result1和result2，而不包括result3。 （在此示例中）
Excel / VBA有内置的方法吗？
解决方法
如果您使用的是Windows Excel O365，则可以使用以下公式进行操作：
D6: =FILTER($B$2:$B$100,IFERROR(SEARCH(FILTERXML("<t><s>"&SUBSTITUTE(A1," ","</s><s>")&"</s></t>","//s"),$A$2:$A$100),FALSE))
注意：：如果要返回匹配单元格的内容，而不是问题中写的内容，只需更改B2:B100 --> A2:A100
另一个字符串中的一个字符串的子字符串
倒置
- 对于您在注释中提到的任务，您可能只需要最后一个第三过程即功能。
- 第二步是如何使用该功能的实际示例。
- 第一个过程是如何使用第二个过程的实际示例。
代码
Option Explicit
' How to use 'getMatchingValues'.
Sub testGetMatchingValues()
' Initialize error handling.
Const ProcName As String = "testGetMatchingValues"
On Error GoTo clearError ' Turn on error trapping.
' Source
Const wsName As String = "Sheet1"
Const rngAddress As String = "A2:A100"
' Target
Const tgtName As String = "Sheet2"
Const tgtFirstCell As String = "A2"
' Other
Const SearchString = "test phrase"
Dim wb As Workbook: Set wb = ThisWorkbook ' The workbook with this code.
' Define Source Range.
Dim rng As Range
Set rng = wb.Worksheets(wsName).Range(rngAddress)
' Write values that contain all sub strings of Search String to Data Array.
Dim Data As Variant
getMatchingValues Data,rng,SearchString
If IsEmpty(Data) Then
GoTo ProcExit
End If
' Write values from Data Array to Target Range.
Set rng = wb.Worksheets(tgtName).Range(tgtFirstCell)
.Resize (UBound(Data) - LBound(Data) + 1)
rng.Value = Application.Transpose(Data)
' Inform user.
MsgBox "Done.",vbInformation,"Success"
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' In each cell of a column range ('ColumnRange'),searches for each sub string
' of a specified string ('SearchString').
' If all sub strings are found,writes the value of the cell
' to a 1D array ('Result1D').
' The search is by default case-sensitive i.e. 'A<>a' (ignoreCase = False).
' It uses the 'foundAllStrings' function.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub getMatchingValues(ByRef Result1D As Variant,_
ColumnRange As Range,_
ByVal SearchString As String,_
Optional ByVal ignoreCase = False)
' Initialize error handling.
Const ProcName As String = "getMatchingValues"
On Error GoTo clearError ' Turn on error trapping.
' Reset Result Array.
Result1D = Empty
' Validate Column Range.
If ColumnRange Is Nothing Then
GoTo ProcExit
End If
' Write values from first column of Column Range to Source Array.
Dim rng As Range: Set rng = ColumnRange.Columns(1)
Dim Source As Variant
If rng.Rows.Count > 1 Then
Source = rng.Value
Else
ReDim Source(1 To 1,1 To 1)
Source(1,1) = rng.Value
End If
' Write values from Source Array to Result Array.
ReDim Result1D(0 To UBound(Source) - 1)
Dim k As Long: k = LBound(Result1D) - 1
Dim i As Long
For i = 1 To UBound(Source)
If foundAllStrings(SearchString,Source(i,1),ignoreCase) Then
k = k + 1
Result1D(k) = Source(i,1)
End If
Next i
' Resize Result Array.
If k >= LBound(Result1D) Then
ReDim Preserve Result1D(LBound(Result1D) To k)
Else
Result1D = Empty
End If
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' In a specified string ('SuperString'),searches for each sub string
' of another specified string ('SearchString').
' If all sub strings are found,it returns 'True',otherwise 'False'.
' The search is by default case-sensitive i.e. 'A<>a' (ignoreCase = False).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function foundAllStrings(SearchString As String,_
ByVal SuperString As String,_
Optional ByVal ignoreCase = False) As Boolean
' Initialize error handling.
Const ProcName As String = "foundAllStrings"
On Error GoTo clearError ' Turn on error trapping.
' Determine case sensitivity.
Dim iCase As Long
If ignoreCase Then
iCase = 1 ' vbTextCompare
End If
' Write sub strings of Search String to Sub Strings Array.
Dim SubStrings As Variant
SubStrings = Split(SearchString) ' " " by default
' Check each sub string if it is contained in Super String.
Dim j As Long
For j = LBound(SubStrings) To UBound(SubStrings)
If InStr(1,SuperString,SubStrings(j),iCase) = 0 Then
GoTo ProcExit
End If
Next j
' All sub strings were found in Super String.
foundAllStrings = True
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Function