Excel VBA 匹配拆分搜索字符串

Question

有没有办法在 Excel 中按每个单词拆分搜索并比较部分匹配项？

例如， 如果我的表包含：

example test phrase | result1
phrase test two     | result2
excluded phrase     | result3

如果我搜索：（使用 A1 作为搜索字段）

searchString = "*test phrase*"
searchItem = Application.Match(searchString, Worksheets("Table").Range("A2:A100"), 0)

这仅返回结果 1，但不返回结果 2，因为它正在查找整个短语，仅按输入的顺序。

输入搜索字符串“测试短语”后，我需要返回 result1 AND result2，不包括 result3。 （在这个例子中）

Excel/VBA 是否有任何内置方法可以做到这一点？

Answer 1

如果你有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

Answer 2

一个字符串在另一个字符串中的子字符串

上下颠倒

• 对于您在 cmets 中提到的任务，您可能只需要最后一个，第三个过程，函数。
• 第二个过程是如何使用该功能的实际示例。
• 第一个过程是如何使用第二个过程的实际示例。

守则

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