Поиск ближайшего похожего текста
Если в слове "хлеб" сделать четыре ошибки,
то получится слово "пиво"!
Имеем два списка. И в том и в другом примерно одни и те же элементы, но записаны они могут быть немного по-разному. Задача - подобрать к каждому элементу в первом списке максимально похожий элемент из второго списка, т.е. реализовать поиск ближайшего максимально похожего текста.
Большой вопрос, в данном случае, что считать критерием "похожести". Просто количество совпадающих символов? Или количество идущих подряд совпадений? Учитывать ли регистр символов или пробелы? Различные положения слов во фразе? Вариантов много и однозначного решения нет - для каждой ситуации тот или иной будет предпочтительнее остальных.
Если следовать принципу Оккама и не усложнять без надобности, то с помощью небольшой макрофункции на 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)
и скопировать формулу на весь столбец.
Обратите внимание, что наша функция не чувствительна к регистру и положению отдельных букв в слове.
Область применения такой функции может быть самой широкой: от автоматического исправления кривых рук оператора, вводящего данные до сравнения списков с разными вариантами написания одной и той же информации.
Ссылки по теме
Очень интересует данная функция, но в моем случае она работает не корректно. Куда можно отправить пример для доработки. Согласен заплатить!
В моем случае в Списке 2 несколько похожих значений
Макрос берет только первый по списку
Можно ли сделать, чтобы он брал все похожие значения?
Как сделать массив из которого будет подбираться значение?
вместо- $D$2:$D$11
Я тоже озадачился этой темой. Ваша статья дала пищу для новых идей.
Детально разбирал ваш код.
Функция Equality у вас реализована не совсем корректно и не очень эффективно.
Во-первых, она пропускает многие комбинации. Например, попробуйте такое: =Equality("0123456789","5678")
Во-вторых, она делает слишком много итераций, хотя в этом нет никакой необходимости.
Более совершенная реализация:
Сам делаю массу ошибок в своём коде при дефиците времени , поэтому примите, как конструктивную критику
Искомое значение: 1-Я СОВЕТСКАЯ УЛ., д.10
Найденное этой функцией значение: Невский пр., д.156
Значение которое должен был найти: 1-я Советская ул. д.10
Что по мнению скрипта общего между искомым и найденным значением ?
Не видя файла сказать сложно. Может у вас там латиница вместо кириллицы или еще что-то неочевидное.
FuzzyLookup("Аникина, 12 (1а)";Диапазон)= "Михаила Немыткина"
и
FindSame( "Аникина, 12 (1а)";Диапазон)="Аникина"
Николай, почему так происходит?
подойдет для исправления опечаток, но не поиска в номенклатуре
мой вариант (тоже далеко не идеал, но работает точнее для последней задачи)
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