Question

我知道vlookup只返回一个结果，但我正在寻找一种方法来搜索2列并返回与此查询匹配的所有结果：

SUBSTITUTE("*"&C2&"*"," ","*")

这样它也会返回类似的匹配。我能够返回第一个匹配（通过vlookup），但我需要返回所有匹配并在一行中显示它们。

如果它会创建一个数组，我可以在行中显示第一个匹配数据中的第一个元素，显示与第二个元素的第二个匹配...依此类推。

到目前为止的VBA：

Function Occur(text, occurence, column_to_check)
  newarray = Split(text, " ")

  Dim temp As New Collection
  Dim intX As Integer

   For i = 1 To 90000
   intX = 1
        For j = 0 To Len(newarray)
             If Not InStr(Range(column_to_check + i).Value, newarray(j)) Then
                intX = 0
             End If
        Next j
        Exit For
        If intX = 1 Then
            temp.Add (Cells(i, column_to_check))
        End If
    Next i

End Function

谢谢！

Answer 1

使用脚本字典和一些数组/范围操作。我在大约30,000行测试了它，并且它比我闪烁的速度快了大约10,000次匹配。

Sub TestWithoutRE()
    Dim dict As Object
    Dim srchStrings() As String
    Dim s As Variant
    Dim colsToSearch As Range
    Dim cl As Range
    Dim allMatch As Boolean
    Dim matchArray As Variant

    'Define the strings you're looking for
    srchStrings = Split([C2], " ")

    'Define the ranges to search:
    Set colsToSearch = Range("F1:G33215")

    'Build a dictionary of the column data
    Set dict = CreateObject("Scripting.Dictionary")
    For Each cl In colsToSearch.Cells
        allMatch = True 'this will be set to false on the first non-matching value, no worries
        'Make sure each word is in the cell's value:
        For Each s In srchStrings
            If InStr(1, LCase(cl), LCase(s)) = 0 Then
                allMatch = allMatch + 1
                Exit For  'exit this if ANY substring is not found
            End If
        Next
        If allMatch Then
            '## As long as all strings were found, add this item to the dictionary
            dict.Add cl.Address, cl.Value
        End If
    Next

    '## Here is your array of matching values:
    matchArray = dict.Items


End Sub

基本上我将搜索参数（C2）拆分为数组。然后我迭代这些列中的每个单元格，从C2测试拆分数组的每个元素。如果找不到C2中的任何单词，那么我将其忽略为部分匹配，您只需要查找两个匹配的单词，而不是特定的顺序。

如果两个单词匹配，请将值添加到字典对象中。

然后，您可以通过引用返回数组的dictionary.Items来访问所有匹配的值。

Answer 2

试试这个。您可以将它用作数组公式，选择合理数量的单元格来显示结果，或者在代码中使用它并以您喜欢的任何方式转储到工作表。

它接受一个要搜索的字符串（它分割并测试单个字符串中的每个单词），然后是要搜索的字符串，范围或数组的Param数组。它返回一个匹配数组，以便您可以使用它作为数组公式或在代码中用作任何其他数组。

用法示例：

=GetAllMatches("two three",A1:A5)单个连续范围的示例
=GetAllMatches("two three",A1,A3:A20,B5:B8,D1)'包含非连续单元格的示例
=GetAllMatches("two three",{"one two","three two","one two three"})数组
=GetAllMatches("two three","one two","one","three two","one two three")示例包含字符串
For each match in GetAllMatches(blah,blahblah):Debug.Print match:Next match代码中使用的示例而非公式

你可能需要调整才能尝试，但我已经在代码中评论了它的作用。

代码示例：

Public Function GetAllMatches(searchFor As String, ParamArray searchWithin()) As Variant

    'I use a ParamArray to handle the case of wanting to pass in non-contiguous ranges to search other
    'e.g. Blah(A1,A2,A3,C4:C10,E5)
    'nice little feature of Excel formulae :)

    Dim searchRange, arr, ele, searchComponents
    Dim i As Long
    Dim results As Collection
    Dim area As Range
    Set results = New Collection

    'generate words to test
    searchComponents = Split(searchFor, " ")

    For Each searchRange In searchWithin
        If TypeOf searchRange Is Range Then 'range (we test to handle user passing in arrays)
            For Each area In searchRange.Areas 'we enumerate to handle multi-area ranges
                arr = area.Value
                If VarType(arr) < vbArray Then 'we test to handle single cell areas
                    If isMatch(arr, searchComponents) Then results.Add arr 'is a match so add to results
                Else 'is an array, so enumerate
                    For Each ele In arr
                        If isMatch(ele, searchComponents) Then results.Add ele  'is a match so add to results
                    Next ele
                End If
            Next area
        Else
            Select Case VarType(searchRange)
                Case Is > vbArray 'user passed in an array not a range
                    For Each ele In searchRange 'enumerate, not iterate, to handle multiple dimensions etc
                        If isMatch(ele, searchComponents) Then results.Add ele  'is a match so add to results
                    Next ele
                Case vbString
                    If isMatch(searchRange, searchComponents) Then results.Add searchRange  'is a match so add to results
                Case Else 'no idea - return an error then fail fast (suppressed if called by an excel formula so ok)
                    GetAllMatches = CVErr(XlCVError.xlErrRef)
                    Err.Raise 1, "GetAllMatches", "Invalid Argument"
            End Select
        End If
    Next searchRange

    'Process Results
    If results.Count = 0 Then 'no matches
        GetAllMatches = CVErr(XlCVError.xlErrNA) 'return #N/A
    Else
        'process results into an array
        ReDim arr(0 To results.Count - 1)
        For i = 0 To UBound(arr)
            arr(i) = results(i + 1)
        Next i
        GetAllMatches = arr 'Return the array of matches
    End If
End Function
Private Function isMatch(ByRef searchIn, ByRef searchComponents) As Boolean
    Dim ele
    For Each ele In searchComponents
        If Not (InStr(1, searchIn, ele, vbTextCompare) > 0) Then
            Exit Function
        End If
    Next ele
    isMatch = True
End Function

示例电子表格：

one                  
one two         
one two three           
one three two           
four three one two

结果： one two three one three two four three one two

模糊Vlookup显示单行的所有匹配结果

2 个答案: