Создал тему, чтобы отшлифовать найденные решения по преобразованию строки к "нормальному" состоянию Для чего это преобразование нужно: для автоматического точного поиска среди строк, отличающихся друг от друга несущественной информацией. А именно, удаление этой информации и приведение "несущественно" разных строк к одному виду
Option Explicit
'Option Private Module
'====================================================================================================
Sub НормализацияДанныхВыделенногоДиапазона()
Dim rng As Range
Set rng = Intersect(Selection, ActiveSheet.UsedRange)
If Not rng Is Nothing Then PRDX_Simplify_Range rng
End Sub
'====================================================================================================
Private Sub PRDX_Simplify_Range(rng As Range)
Dim ar As Range
Dim arr, arrOne(1 To 1, 1 To 1), r&, c&
For Each ar In rng.Areas
If ar.Cells.count = 1 Then
arrOne(1, 1) = ar.Value2
arr = arrOne
Else
arr = ar.Value2
End If
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
PRDX_Simplify arr(r, c)
Next r
Next c
ar.Value2 = arr
Next ar
End Sub
'====================================================================================================
Private Sub test()
Dim x, a, n, t
Const check$ = "25/1 а;а.а;а 5 а а.sd аsd аsdа:s 2 12 1 аs d 6 а dаs 2,-,3/12-34.выа ыва.ы.в:в:в 13 15 аы ва ыв 7.7\/.25"
a = " - ,. - 25 /1aa;aаа.аа;;aa5a(a......sd)asd asda:s2 12 1as{}d6a das 2 ,--,, 3/12 --34.выа••ыва .ы. вв:вввbb:bbb 13 15 аыы ва ыв7 () . () 7\ \ // / / . 25 / / . , "
t = Timer
For n = 1 To 10000
x = a
PRDX_Simplify x
Next n
Debug.Print Format(1000 * (Timer - t), "0 ms"), x = check, "«" & x & "»"
End Sub
'====================================================================================================
Private Sub PRDX_Simplify(vl)
If IsError(vl) Then vl = "!!! ОШИБКА !!!": Exit Sub
vl = LCase$(Trim(vl)): If Len(vl) = 0 Then Exit Sub
Dim dicF As Dictionary
Static RE As RegExp, REds As RegExp, REcyr As RegExp, REdd As RegExp, REis As RegExp, REtr As RegExp
Static dicR As Dictionary
Dim x, y, i&, l&
If RE Is Nothing Then
Set RE = New RegExp: RE.Global = True: RE.Pattern = "[^ ,-;\\_a-zёа-я]" ' удаление всего, кроме указанных символов
Set REds = New RegExp: REds.Global = True: REds.Pattern = " *([,-/:;\\_]) *" ' удаление пробелов СЛЕВА и СПРАВА от символов
Set REdd = New RegExp: REdd.Global = True: REdd.Pattern = "([ ,-/:;\\_d-zа-я])(?:\1)+" ' удаление двойных символов, идущих подряд
Set REis = New RegExp: REis.Global = True: REis.Pattern = "(\d(?=[d-zа-я])|[d-zа-я](?=\d))" ' вставка пробелов между числами и текстом
Set REtr = New RegExp: REtr.Global = True: REtr.Pattern = " {2,}" ' удаление двойных пробелов
x = Array("a", "b", "c", "e", "h", "k", "m", "o", "p", "t", "x", "y", "ё", "й") ' замена латиницы на похожую визуально кириллицу + замена "ё" на "е" и "й" на "и"
y = Array("а", "в", "с", "е", "н", "к", "м", "о", "р", "т", "х", "у", "е", "и")
Set dicR = New Dictionary
For i = 0 To UBound(x)
dicR.Add x(i), y(i)
Next i
Set REcyr = New RegExp
REcyr.Global = True
REcyr.Pattern = "[" & Join(x, "") & "]"
End If
If RE.test(vl) Then vl = RE.Replace(vl, " ")
Do While vl Like "[ ,-/:;\\]*"
vl = Mid(vl, 2)
Loop
i = Len(vl)
Do While vl Like "*[ ,-/:;\\_]"
i = i - 1
vl = Left(vl, i)
Loop
If REds.test(vl) Then vl = REds.Replace(vl, "$1")
If REcyr.test(vl) Then
Set dicF = New Dictionary
For Each x In REcyr.Execute(vl)
x = dicF(x)
Next x
For i = 0 To dicF.count - 1
x = dicF.Keys()(i)
vl = Replace(vl, x, dicR(x))
Next i
End If
If REdd.test(vl) Then vl = REdd.Replace(vl, "$1")
If REis.test(vl) Then vl = REis.Replace(vl, "$1 ")
If REtr.test(vl) Then vl = REtr.Replace(Trim(vl), " ")
End Sub
'====================================================================================================
Скрин с примерами из файла (жёлтым выделено то, что стало дубликатами после обработки)
Изменено: Jack Famous - 29.10.2020 09:39:52(Добавил примеры преобразований)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Ну, и да, не мешало бы следовать этому не замысловатому правилу
Цитата
2.3. Приложите файл(ы) с примером (общим весом не более 300Кб) в реальной структуре и форматах данных того, что есть сейчас и того, что хотелось бы на выходе.
ну вообще раньше в шаблоне не было звёздочек и именно поэтому я и разбивал на 2 шаблона с "пробел+". Звёздочки решили проблему - совсем забыл про них. Работает
блин - а я всё заменял на $1, хотя нужно было просто удалить. Работает (в том числе объединённый шаблон)
Цитата
Андрей VG: не мешало бы следовать этому не замысловатому правилу … приложите файл(ы) с примером
тут такое дело: обработчик был рабочий с самого начала, только некоторые шаблоны были разделены и/или заменены. То есть итог обработки (цель и пример) был, только нужно было, конечно, его отдельно вынести для визуального контроля
Что ж - всё работает. Ещё раз спасибо Андрею! Финальный код в стартовом сообщении. Удаление символов слева и справа пришлось-таки заменить на строковые функции, которые в данном случае стабильно быстрее на 10-15% (-5% слева и -25% справа по времени)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Vladimir Chebykin, спасибо за положительный отзыв! Всегда пожалуйста Скоро выложу код для нечёткого сравнения методом перестановки слов
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
А примера нет что куда код преобразовывает? Первичные данные и готовый результат. А то файл пустой зачем-то приложили, а что он делает - не понятно. Вы бы хотя бы 10 строк заполнили в файле, а рядом преобразованные данные. Тогда было бы понятно. А так люди придут в тему... ну, что-то про Regexp... а что куда и как....
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Vladimir Chebykin: я бы предложил вообще эту тему сохранить в копилку … Не знаю, как это делается
ещё раз спасибо за положительную оценку я и сам не знаю, как это делается
Я не против, но позже. Эта тема вместе с другими войдёт в сборник Нечёткий поиск / Fuzzy Lookup Когда он будет готов и оформлен, тогда и можно будет переносить
Копилка пополняется очень редко и складывается такое ощущение, что в ней ограничено место Механизм и критерии отбора по "полезности" также не обозначены, поэтому остаётся только предоставить решения по переносу на усмотрение модераторов …
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄