Option Explicit
'====================================================================================================
Sub ПодтянутьНеТочно()
Dim dic As New Dictionary
Dim rng As Range, rng2 As Range, ar As Range
Dim tm!, i&, n&, r&, t&, f&, AC&
Dim x, w, arr, tmp, arrU(), arrO(), arrNew()
Dim arrV(), arrI() As Long

' ===== ЭТАП 0. Проверки диапазонов ============================
Set rng = Intersect(Selection, ActiveSheet.UsedRange)
If Not FILE_SelectRange(rng, "ЧТО ищем") Then Exit Sub
Set rng2 = rng

If Not FILE_SelectRange(rng, "ГДЕ ищем") Then Exit Sub

tm = Timer
Application.StatusBar = "Этап 1. Готовим данные …"
ReDim arrU(rng.Cells.count - 1)
ReDim arrO(UBound(arrU)): i = -1

    For Each ar In rng.Areas    ' собираем 2 массива из справочника
        arr = ar.Value
        If Not IsArray(arr) Then arr = Array(arr)

        For Each x In arr
            For Each w In Split(x)
                w = dic(w)      ' словарь слов
            Next w

            i = i + 1
            arrU(i) = dic.Keys  ' массив из словаря слов очередной строки справочника
            dic.RemoveAll
            arrO(i) = x         ' массив оригинальных строк справочника
        Next x
    Next ar

Application.StatusBar = False
If i = -1 Then MsgBox "Справочник не сформирован!", vbCritical, Format$(Timer - tm, "0.00 сек"):                  Exit Sub
If i <> UBound(arrU) Then MsgBox "Справочник наполнен некорректно!", vbCritical, Format$(Timer - tm, "0.00 сек"): Exit Sub
Application.StatusBar = "Этап 2. Проверяем …"

Set rng = rng2
n = -1: r = 0
ReDim arrNew(1 To (UBound(arrU) + 1) * rng.Cells.count, 1 To 5) ' новый массив с запасом
ReDim arrI(UBound(arrNew, 1) - 1)                               ' массив индексов для сортировки
ReDim arrV(UBound(arrI))                                        ' массив значений для сортировки

    For Each ar In rng.Areas    ' собираем массив "ищем - массив найденного"
        arr = ar.Value
        If Not IsArray(arr) Then arr = Array(arr)

        For Each x In arr
            t = t + 1: w = x                            ' считаем количество строк для поиска и запоминаем искомую строку в переменную

            If FILE_Fuzzy_Element(x, arrU, arrO) Then   ' если для очередной искомой строки были найдены подобия, то …
                f = f + 1                               ' … увеличиваем счётчик совпадений

                For Each tmp In x       ' цикл по "строкам" найденных подобий
                    n = n + 1: arrI(n) = n
                    r = r + 1: arrNew(r, 1) = w

                    For i = 2 To 4      ' заполняем столбцы нового массива из массива подобий
                        arrNew(r, i) = tmp(i - 2)
                    Next i

                    arrV(n) = arrNew(r, 1) & 10000 * (1 - arrNew(r, 4)) ' для обратной сортировки сцепляем искомую строку и (100% - % подобия)
                Next tmp
            Else
                n = n + 1: arrI(n) = n
                r = r + 1: arrNew(r, 1) = w
                arrV(n) = arrNew(r, 1)
            End If
        Next x
    Next ar

Application.StatusBar = False
If f = 0 Then MsgBox "Неточных соответствий не найдено…", vbExclamation, Format$(Timer - tm, "0.00 сек"): Exit Sub
Application.StatusBar = "Этап 3. Выводим отчёт …"

    If n <> UBound(arrI) Then
        ReDim Preserve arrI(n)
        ReDim Preserve arrV(n)
    End If

FILE_Sort_Array1x_WithInd arrV, arrI, 0, UBound(arrI)   ' сортировка индексов
ReDim arrO(1 To r, 1 To UBound(arrNew, 2))              ' новый массив нужного размера

    For r = 1 To UBound(arrO, 1)    ' пересобираем массив
        i = arrI(r - 1)             ' новый индекс

        For n = 1 To UBound(arrO, 2)
            arrO(r, n) = arrNew(i + 1, n)
        Next n

        arrO(r, 5) = arrO(r, 4)
    Next r

arrO(1, 4) = 1
    For r = 2 To UBound(arrO, 1)    ' проставляем ранг
        If arrO(r, 1) = arrO(r - 1, 1) Then
            arrO(r, 4) = arrO(r - 1, 4) + 1
        Else
            arrO(r, 4) = 1
        End If
    Next r

Application.ScreenUpdating = False
Worksheets.Add After:=ActiveSheet

Set rng = Cells(1, 1).Resize(UBound(arrO, 1), UBound(arrO, 2))
rng.Value = arrO
Cells(1, 1).Resize(1, 5).Value = Array("ИСКАЛИ", "НАШЛИ", "СОВПАВШЕЕ", "РАНГ", "k")

Columns(5).NumberFormat = "0.00%"
    With Cells(2, 4).Resize(UBound(arrO, 1), 2)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With

    With Cells(2, 1).Resize(UBound(arrO, 1), UBound(arrO, 2))
        .ColumnWidth = 5
        .EntireColumn.AutoFit
    End With

    For n = 1 To 3
        If Columns(n).ColumnWidth > 100 Then Columns(n).ColumnWidth = 100
    Next n

Application.StatusBar = False
Application.Calculation = AC
Application.ScreenUpdating = True
MsgBox "Найдено неточных соответствий: " & f & " из " & t & vbLf & "Требуется ВИЗУАЛЬНЫЙ контроль", vbInformation, Format$(Timer - tm, "0.00 сек")
End Sub
'====================================================================================================
Function FILE_SelectRange(rng As Range, Optional txtTitle$ = "ДИАПАЗОН") As Boolean
Dim cl As Range, sA As Boolean

sA = Application.ScreenUpdating
Application.ScreenUpdating = True

If rng Is Nothing Then Set rng = Intersect(Selection, ActiveSheet.UsedRange)
On Error Resume Next
Set cl = Application.InputBox("Выделите мышкой " & txtTitle, "ВЫДЕЛЕНИЕ ДИАПАЗОНА", Replace$(rng.Address, ",", ";"), Type:=8)

    If Not Err Then
        Set rng = cl
        FILE_SelectRange = True
    End If

ex: Application.ScreenUpdating = sA
On Error GoTo 0
End Function
'====================================================================================================
Sub FILE_Sort_Array1x_WithInd(arrVal(), arrInd() As Long, l&, U&)
Dim x, y, n&, i&, j&

i = l: j = U: x = arrVal((l + U) \ 2)

        Do
            Do While arrVal(i) < x: i = i + 1: Loop
            Do While x < arrVal(j): j = j - 1: Loop
            If i <= j Then
                y = arrVal(i): arrVal(i) = arrVal(j): arrVal(j) = y
                n = arrInd(i): arrInd(i) = arrInd(j): arrInd(j) = n
                i = i + 1: j = j - 1
            End If
        Loop Until i > j

If l < j Then FILE_Sort_Array1x_WithInd arrVal, arrInd, l, j
If i < U Then FILE_Sort_Array1x_WithInd arrVal, arrInd, i, U
End Sub
'====================================================================================================

Option Explicit
'====================================================================================================
Function FILE_Fuzzy_Element(ByRef tmpVl, arrUniq(), arrOrigin()) As Boolean
Dim dSearch As New Dictionary
Dim w, arrComp(), arrOut(), arrTmpO(2)
Dim limit#, kS#, kD#, nS&, lS&, nO&, i&, c&, n&

    For Each w In Split(tmpVl)  ' получаем словарь (уникальный список) слов искомой ячейки
        w = dSearch(w)
    Next w

limit = 0.95                        ' нижний порог для пересчёта подобия справочника
lS = Len(Join(dSearch.Keys, ""))    ' длина слов (уникальных) ИСКОМОЙ строки без пробелов
nS = dSearch.count                  ' количество ИСКОМОЙ строки без пробелов
ReDim arrOut(UBound(arrUniq))       ' массив для ВЫВОДА совпадений
nO = -1                             ' сбрасываем индекс

    For i = 0 To UBound(arrUniq)    ' цикл по всем элементам одномерного массива массивов уникальных слов справочника
        c = -1                      ' сбрасываем индекс для массива подходящих слов
        ReDim arrComp(nS - 1)       ' создаём/очищаем динамический массив для ПОДСЧЁТА совпадений

        For Each w In arrUniq(i)        ' цикл по уникальным словам справочника
            If dSearch.Exists(w) Then   ' если слово совпало, то …
                c = c + 1       ' … увеличиваем индекс
                arrComp(c) = w  ' … заполняем массив очередным совпавшим словом
            End If
        Next w

        If c <> -1 Then                             ' если в очередной строке найдены совпадения, то …
            arrTmpO(0) = arrOrigin(i)                   ' 1ый элемент массива подобия: строка справочника
            arrTmpO(1) = Trim(Join(arrComp))            ' 2ой элемент массива подобия: строка совпавших слов

            n = Len(Replace$(arrTmpO(0), " ", ""))      ' длина слов (оригинальных) СПРАВОЧНИКА без пробелов
            c = Len(Replace$(arrTmpO(1), " ", ""))      ' длина НАЙДЕННЫХ слов без пробелов

            kS = c / lS                         ' коэффициент подобия совпавшей строки к ИСКОМОЙ (основной)
            kD = c / n                          ' коэффициент подобия совпавшей строки к СПРАВОЧНОЙ (второстепенный)
            kD = limit + (kD * (1 - limit))     ' пересчёт второстепенного коэффициента от заданной нижней границы

            arrTmpO(2) = Round(kS * kD, 10)     ' 3ий элемент массива подобия: общий коэффициент подобия
            nO = nO + 1: arrOut(nO) = arrTmpO   ' заполняем очередной элемент массива для вывода массивом подобия
        End If
    Next i

If nO = -1 Then Exit Function                           ' если совпадений по искомой строке не было, то выходим
If nO < UBound(arrOut) Then ReDim Preserve arrOut(nO)

tmpVl = arrOut
FILE_Fuzzy_Element = True   ' функция возвращает ИСТИНУ, то есть хотя бы одно подобие в справочнике было найдено
End Function
'====================================================================================================