Fuzzy Vlookup для отображения всех совпадающих результатов в одной строке

Попробуй это. Вы можете использовать его как формулы массива, выбирая разумное количество ячеек для отображения результата, или использовать его в коде и выгружать на рабочий лист любым удобным для вас способом.

Он принимает одну строку для поиска (которую он разбивает и проверяет каждое слово в одной строке), затем массив 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

Используйте словарь сценариев и некоторые манипуляции с массивами/диапазонами. Я проверил это примерно на 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, который возвращает массив.