Fuzzy Vlookup在一行中显示所有匹配的结果

Question

I'm aware that vlookup only returns one result, but I'm looking for a way to search across 2 columns and return all results that match this query:

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

This way it returns similar matches as well. I'm able to return the first match (through a vlookup), but I need to return all matches and display them across a row.

If it would create an array, I could display the first match in the row with the first element in the array, display the second match with the second element.. and so on.

VBA so far:

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

Thanks!

Answer 1

Use a scripting dictionary and some array/range manipulation. I tested this on about 30,000 rows and it returned about 10,000 matches faster than I could blink.

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

Basically I split your search parameter ( C2 ) in to an array. I then iterate each cell in these columns, testing against each element of the split array from C2 . If any of the words from C2 are not found then I ignore it as a partial match, you're only looking for both words matching, in no particular order.

If both words match, add the value to a dictionary object.

You can then access all matching values by referring to the dictionary.Items which returns an array.

Answer 2

Try this. You can either use it as an array formulae selecting a reasonable number of cells to display the result, or use it in code and dump to the worksheet in whatever fashion you like.

It accepts a single string to search for (which it splits and tests each word within the single string), then a Param Array of strings, ranges or arrays to search in. It returns an array of matches so you can either use it as an array formula or use in code as any other array.

Usage examples:

• =GetAllMatches("two three",A1:A5) example with single contiguous range
• =GetAllMatches("two three",A1,A3:A20,B5:B8,D1) 'example with non-contiguous cells
• =GetAllMatches("two three",{"one two","three two","one two three"}) example with array
• =GetAllMatches("two three","one two","one","three two","one two three") example with strings
• For each match in GetAllMatches(blah,blahblah):Debug.Print match:Next match example of use in code instead of a formula

You may have to tweak to taste but I have commented what it is doing in the code.

Code example:

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

Example spreadsheet:

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

results: one two three one three two four three one two