Поиск ближайшего похожего текста

Если в слове "хлеб" сделать четыре ошибки,
то получится слово "пиво"!

Имеем два списка. И в том и в другом примерно одни и те же элементы, но записаны они могут быть немного по-разному. Задача - подобрать к каждому элементу в первом списке максимально похожий элемент из второго списка, т.е. реализовать поиск ближайшего максимально похожего текста.

Большой вопрос, в данном случае, что считать критерием "похожести". Просто количество совпадающих символов? Или количество идущих подряд совпадений? Учитывать ли регистр символов или пробелы? Различные положения слов во фразе? Вариантов много и однозначного решения нет - для каждой ситуации тот или иной будет предпочтительнее остальных.

Если следовать принципу Оккама и не усложнять без надобности, то с помощью небольшой макрофункции на VBA можно реализовать самый очевидный вариант - поиск по максимальному количеству совпадений символов. Он не идеален, но для большинства ситуаций работает вполне надежно:

Поиск ближайшего похожего текста

Чтобы добавить такую пользовательскую функцию, сначала войдем в редактор Visual Basic (вкладка Разработчик - Visual Basic или Alt+F11) и добавим туда новый модуль через меню Insert - Module. Затем в получившийся пустой модуль надо скопировать вот такой код нашей функции:

Function FuzzyLookup(Lookup_Value As String, Tbl As Range) As String
Dim cell As Range, txt As String, p As Integer, pos As Integer, maxp As Integer, maxstr As String

    For Each cell In Tbl    'перебираем все ячейки в таблице
        txt = cell
        p = 0
        For i = 1 To Len(Lookup_Value)  'проходим по символам в искомом тексте
            pos = InStr(1, txt, Mid(Lookup_Value, i, 1), vbTextCompare)   'ищем вхождение
            If pos > 0 Then
                p = p + 1       'увеличиваем счетчик совпадений
                txt = Left(txt, pos - 1) & Right(txt, Len(txt) - pos)   'убираем найденный символ из текста
            End If
        Next i
        If p > maxp Then    'запоминаем наилучшее совпадение
            maxp = p
            maxstr = cell
        End If
    Next cell
    FuzzyLookup = maxstr
End Function

Теперь можно закрыть редактор и вернуться в Excel. В мастере функций на вкладке Формулы - Вставить функцию (Formulas - Insert Function) в категории Пользовательские (User defined) появится наша новая функция FuzzyLookup, которую можно использовать со следующими аргументами:

=FuzzyLookup(текст_который_ищем; диапазон_поиска)

Т.е. в показанном выше примере в ячейку B2 надо ввести

=FuzzyLookup(A2;$D$2:$D$22)

и скопировать формулу на весь столбец.

Обратите внимание, что наша функция не чувствительна к регистру и положению отдельных букв в слове.

Область применения такой функции может быть самой широкой: от автоматического исправления кривых рук оператора, вводящего данные до сравнения списков с разными вариантами написания одной и той же информации.

Ссылки по теме

 


Serge
27.10.2012 18:06:11
А как же встроенная функция ПОИСКПОЗ?!Если третий аргумент не задавать равным нулю (строгое соответствие), то результат будет таким же (максимально приближеное значение). Или функция ПРОСМОТР?
27.10.2012 18:08:03
Иретий аргумент в функциях ПРОСМОТР, ПОИСКПОЗ и ВПР, который включает приблизительный просмотр, предназначается для чисел и с текстами работает некорректно - попробуйте сами ;)
24.01.2013 18:36:42
и еще одно - а можно переделать эту функцию так, что бы она показывала кол-во совпадающих символов?
07.02.2013 16:56:04
ой спасибо!
01.03.2013 10:52:20
Здравствуйте!
Очень интересует данная функция, но в моем случае она работает не корректно. Куда можно отправить пример для доработки. Согласен заплатить!
03.03.2013 09:02:46
На форуме есть раздел Работадля таких случаев.
31.05.2013 15:51:30
Здравствуйте!

В моем случае в Списке 2 несколько похожих значений
Макрос берет только первый по списку
Можно ли сделать, чтобы он брал все похожие значения?
31.05.2013 16:24:11
Макрос берет не первый, а самый похожий вариант, где больше всего степень совпадения с оригиналом.
03.10.2013 12:33:01
Подскажите!
Как сделать массив из которого будет подбираться значение?
вместо-      $D$2:$D$11
08.10.2013 11:23:26
Александр, что значит в вашем понимании "массив"? Чем вам обычный диапазон не подходит?
11.01.2014 13:45:37
Уважаемый Николай, а этот пример действителен для текстовых выражений, содержащихся в одной ячейке? В смысле, если больше одного слова, знаки препинания и прочие символы?
12.01.2014 17:08:37
Конечно, а почему нет? Принцип тот же - ищется максимальное совпадение символов.
10.07.2014 08:33:19
Спасибо, Николай!
21.11.2014 16:29:57
Николай, добрый вечер.
Я тоже озадачился этой темой. Ваша статья дала пищу для новых идей.
Детально разбирал ваш код.
Функция Equality у вас реализована не совсем корректно и не очень эффективно.
Во-первых, она пропускает многие комбинации. Например, попробуйте такое: =Equality("0123456789","5678") ;).
Во-вторых, она делает слишком много итераций, хотя в этом нет никакой необходимости.
Более совершенная реализация:
Function Equality(t1 As String, t2 As String) As Long
  For n = Len(t1) To 1 Step -1
    For k = 1 To Len(t1) - n + 1
      If t2 Like "*" & Mid(t1, k, n) & "*" Then
        If n > Equality Then
          Equality = n
          Exit Function
        End If
      End If
    Next
  Next
End Function
 
Что касается FindSame, то там 2 одинаковых вызова функции Equality - лучше бы оставить один (через промежуточную переменную).
Сам делаю массу ошибок в своём коде при дефиците времени , поэтому примите, как конструктивную критику :)
23.11.2014 08:47:08
Никаких обид, Денис, и спасибо за улучшения. Я этот код писал года три назад, на самом деле, и сейчас смотрю на него и понимаю, что сегодня делал бы все по-другому.
03.10.2016 10:48:14
Денис, а где вы нашли в коде функции FuzzyLookup Николая Функцию Equality? :) А если вы просто предлагаете добавить ваш код в код Николая, то в какую часть кода Николая вы рекомендуете его поставить? Спасибо за ответ.
21.11.2014 16:35:39
Тем не менее, когда я тестировал свою и вашу функции, то ваша оказалась по времени всего лишь на 22% хуже (ну без учёта, что она может кое-что упустить). Так что не всё так страшно. Видимо операции обращения к диапазонам занимают львиную долю времени.
25.12.2014 12:14:04
Автор объясняй:

Искомое значение: 1-Я СОВЕТСКАЯ УЛ., д.10
Найденное этой функцией значение:    Невский пр., д.156
Значение которое должен был найти:   1-я Советская ул. д.10

Что по мнению скрипта общего между искомым и найденным значением ?
27.12.2014 20:01:54
Вы, наверное, к Николаю обращались. Если вариант Николая по каким-то причинам не устроил, то посмотрите на этот.
27.12.2014 23:31:33
Видимо, остальные варианты были еще хуже.
Не видя файла сказать сложно. Может у вас там латиница вместо кириллицы или еще что-то неочевидное.
09.02.2017 04:08:15
Не знаю, кому как, а мой опыт работы с двумя функциями показал, что FuzzyLookup куда больше ошибок (больших несовпадений) выдает, чем FindSame. Пример работы функций:
FuzzyLookup("Аникина, 12 (1а)";Диапазон)= "Михаила Немыткина"
и
FindSame( "Аникина, 12 (1а)";Диапазон)="Аникина"
Николай, почему так происходит?
26.12.2017 04:16:58
потому что данная функция просто ищет количество совпадающих символов и совсем не обращает внимания на их порядок (то есть слова).
подойдет для исправления опечаток, но не поиска в номенклатуре

мой вариант (тоже далеко не идеал, но работает точнее для последней задачи)

Function realfind(ByVal what As Range, ByVal where As Range)

    what_arr = Split(cleanup(what), " ";)
    ReDim rezult(1 To where.Rows.Count)
    For i = LBound(rezult) To UBound(rezult)
        For n = LBound(what_arr) To UBound(what_arr)
        
            fnd = InStr(1, where(i, 1), what_arr(n), vbTextCompare)
            If fnd > 0 Then rezult(i) = rezult(i) + 1
        Next n
    Next i
    rez = rezult(LBound(rezult))
    For i = LBound(rezult) To UBound(rezult)
        If rezult(i) > rez Then rez = rezult(i): realfind = i
    Next i
realfind = where(realfind, 1)
End Function

Private Function cleanup(what)
    Set re = CreateObject("vbscript.regexp";)
    re.Global = True
    re.Pattern = "[^\dA-Za-z]"
    cleanup = Application.Trim(re.Replace(what, " ";))

End Function
21.06.2018 15:20:23
Для нечеткого поиска лучше использовать оценку редакционного расстояния (см. алгоритм определения расстояния Дамерау-Левенштейна)
06.11.2019 18:19:54
Можно ли реализовать данное решение в Power Query/BI/Pivot?
11.11.2019 09:29:11
Сентябрьское обновление Office 365 добавляет нечеткий поиск Fuzzy Lookup в Power Query и BI как штатную возможность при объединении таблиц ;)
22.01.2021 13:05:42
Здравствуйте. Скажите, пожалуйста что поменять, чтобы не искать по символам, а по их приблизительным комбинациям? Чтобы находить предложения с приблизительно такими же словами. Потому как, если список огромный, макрос находит просто предложения с теми же символами, в примерно том же количестве. А это не значит, что предложение уже соответствует искомому. :) буду рада любой помощи. Заранее спасибо.
04.03.2021 12:48:23
Николай добрый день!
Попробовал на своих данных модуль надстройку Fuzzy Lookup.
При выполнении выдаёт ошибку.
Не пойму что не так.
Ссылка на файл здесь: yadi.sk/i/_zMZZT4h8cdohg

Посмотрите, по возможности.
А по 2 колонкам можно так искать? спасибо
13.10.2021 08:16:37
Здравствуйте,
У меня один вопрос,  помогите пожалуйста, тут я написал что если в В1:В6 есть Ана то пуст покажет что рядом с ним на А и тут две Аны, а надо чтобы показала обе результат Аны, что надо делать?
ABCDE
1хорошаяАна
2красиваяМанаАна
3молодаяБана==ИНДЕКС(A1:A6;ПОИСКПОЗ(D2;B1:B6;0))
4прекраснаяКана
5красиваяАнамне нужна чтоб результат должен быть
6белаяШанахарошая красивая
03.02.2022 19:38:49
Добрый день ! Поиск по интернету подобной функции привел меня на эту страницу. Попробовал использовать вашу функцию. Она почему то ищет совсем не то, что следует. Результат выдает совсем другое значение, далекое от похожести, хотя в диапазоне поиска есть очень похожее.
Проверял на Excel 2016 и Excel 2021. Не подскажете ?
Наверх