Как из текста при получении русского слова исключить слова, содержащие в конце слова ая или ый или ое?, в продолжение темы "Как из текста-каши получить первое русское слово"
Как из текста при получении русского слова (уже реализовано в теме "Как из текста-каши получить первое русское слово") исключить слова , содержащие в конце слова ая или ый или ое?
Код
Sub Main()
Const MinLength = 4 ' Мин. длина слова в символах
Dim i As Long, a() As Variant, Rng As Range, s As String
' Задать диапазон входных данных
With ThisWorkbook.Sheets(1)
Set Rng = .Range("d2", .Cells(.Rows.Count, "d").End(xlUp))
End With
a() = Rng.Value
' Найти первоое русское слова по шаблону
With CreateObject("VBScript.RegExp")
.Global = False
.IgnoreCase = True
.Pattern = " ([А-ЯЁ\-]{" & MinLength & ",})\,? "
For i = 1 To UBound(a)
s = Trim(a(i, 1))
If Len(s) = 0 Then
a(i, 1) = Empty
Else
With .Execute(" " & s & " ")
If .Count > 0 Then
a(i, 1) = LCase(.Item(0).SubMatches(0))
Else
a(i, 1) = "(нет)"
End If
End With
End If
Next
End With
' Поместить результат в столбец [I]
Rng.EntireRow.Columns(6).Value = a()
End Sub
getana, показываю вариант, не вникая в предысторию…
Код
…
Dim x, слово, i&
Dim старое() ' одномерный массив исходного списка (предполагается, что уже существует и заполнен)
Dim новое() ' одномерный массив для подходящих слов
ReDim новое(ubound(старое))
For each слово in старое
For each x in Array("ая", "ое", "ый")
If Right$(слово,Len(x))<>x Then новое(i)=слово: i=i+1
Next x
Next слово
ReDim Preserve новое(i-1)
…
Модераторам: название темы «Исключить из выбора слова с определёнными окончаниями»
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Sanja, не получает в вашем примере первое русское слова без окончания "ая" . Надо из текста "Душевая колонна" получить результат: "колонна" Jack Famous, можно показать в примере конкретно моего макроса в приложении?
Вариант для текущего и добавленного к нему предыдущего списка
Код
Sub Main()
Const MinLength = 4 ' Мин. длина слова в символах
Const ExcludeList = "ая,ый,ое,ся,яг" ' Окончания игнорируемых слов
Const Pattern1 = "[ ,\. ]" ' 1-й символ это CHR(160), последний - пробел
Const Pattern2 = "\b_([А-ЯЁ\-]{" & MinLength & ",})[( ]"
Dim i As Long, a() As Variant, Obj As Object, Rng As Range, s As String
' Задать диапазон входных данных
With ThisWorkbook.Sheets(1)
Set Rng = .Range("d2", .Cells(.Rows.Count, "d").End(xlUp))
End With
a() = Rng.Value
' Найти первое русское слова по шаблону
With CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = True
For i = 1 To UBound(a)
s = Trim(a(i, 1))
If Len(s) = 0 Then
a(i, 1) = Empty
Else
a(i, 1) = "(нет)"
' --> Исключения из правил
If InStr(1, s, "душевая", 1) > 0 Then a(i, 1) = "душевая"
If InStr(1, s, "хром", 1) > 0 Then s = Replace(s, "хром", "", Compare:=1)
If InStr(1, s, "туал.", 1) > 0 Then s = Replace(s, "туал.", "", Compare:=1)
' <-- Конец исключений
.Pattern = Pattern1
s = .Replace(s, " _")
.Pattern = Pattern2
For Each Obj In .Execute("_" & s & " ")
s = LCase(Obj.SubMatches(0))
If InStr(ExcludeList, Right(s, 2)) = 0 Then
a(i, 1) = s
Set Obj = Nothing
Exit For
End If
Next
End If
Next
End With
' Поместить результат в столбец [F]
Rng.EntireRow.Columns("F").Value = a()
End Sub
Изменено: ZVI - 22.07.2019 07:32:32(CHR(160) не вставляется в код на форуме!)
ZVI, надо исключить не конкретные слова, а все слова с окончаниями "ая" "ый" "ое" . А то список с такими окончаниями в разных прайсах может быть огромен!
ZVI, не заметил первые строки, спасибо - попробую от пишусь . Вы как я понял сделали 2 варианта на выбор: и исключить с окончаниями и исключить какие то др слова дополнительно.
Фрагмент кода "Исключения из правил" не принципиальный, его можно исключить, он исправляет всего лишь несколько не очень точных результатов из всего списка.
getana: можно показать в примере конкретно моего макроса в приложении?
В примере ВАШЕГО — нет, но ПО ТЕМЕ вот готовый макрос
Код
Option Explicit
'===========================================================================================
Private Sub WordFilter()
Dim arr, rng As Range, ar As Range, r&, c&, t!
t = Timer: Application.ScreenUpdating = False
Set rng = Intersect(Selection, ActiveSheet.UsedRange)
For Each ar In rng.Areas
If ar.Count = 1 Then
ar.Value2 = WF(ar.Value2)
Else
arr = ar.Value2
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
arr(r, c) = WF(arr(r, c))
Next r
Next c
ar.Value2 = arr
End If
Next ar
Application.ScreenUpdating = True
MsgBox "Обработано ячеек: " & rng.Count & vbLf & vbLf & "Время работы макроса: " & Format$(Timer - t, "0.00 сек."), vbInformation, "ГОТОВО"
End Sub
'===========================================================================================
Private Function WF(ByVal iVal)
Dim x, word, temp, arrOld, arrNew(), i&, flag As Boolean
iVal = Replace$(iVal, Chr(160), " ")
iVal = Application.Clean(iVal)
iVal = Application.Trim(iVal)
WF = "": If Len(iVal) = 0 Then Exit Function
If InStr(1, iVal, " ") Then
arrOld = Split(iVal)
Else
ReDim arrOld(0): arrOld(0) = iVal
End If
ReDim arrNew(UBound(arrOld)): i = -1
For Each word In arrOld
temp = DelTrash(word)
If Len(temp) Then
flag = True
For Each x In Array("ая", "ое", "ый")
If Right$(temp, Len(x)) = x Then flag = False
Next x
If flag Then i = i + 1: arrNew(i) = word
End If
Next word
If i = -1 Then Exit Function
ReDim Preserve arrNew(i): WF = DelTrash(Join(arrNew))
End Function
'===========================================================================================
Private Function DelTrash(ByVal iVal)
Dim x
For Each x In Array(".", ",", "-", "/")
If Left$(iVal, 1) = x Then iVal = Mid$(iVal, 2)
If Right$(iVal, 1) = x Then iVal = Left$(iVal, Len(iVal) - 1)
Next x
DelTrash = iVal
End Function
'===========================================================================================
Изменено: Jack Famous - 21.07.2019 10:58:16(UPD: теперь удаляет "мусор" в конце строки в виде точек, запятых и т.д.)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
ZVI, идеальная работа - быстро, качественно и все по делу. Спасибо, все работает на 100% пост #6 . Изначально и не рассчитывал, что до идеализма можно все довести...
getana написал: Спасибо, все работает на 100% пост #6
Пожалуйста
Цитата
sokol92 написал: ... для идеала нужны словари, таблицы Зализняка и т.п.
Владимир, в идеале - да, а у меня решение просто подогнано под конкретные данные Ну, и маленький трюк придуман с "\b", чтобы работало не только с англо-словами.
sokol92, приветствую! Если это вы мне, то какой вопрос (от ТС) - такой и ответ)) список исключаемых окончаний легко правится в строке №47 кода — For Each x In Array("ая", "ое", "ый")
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
У меня работает. Вот если бы Вы приложили excel файл, в котором не работает, то было бы понятнее. Скопируете то, что написали в предыдущем сообщении и вставьте в ячейку - "шкафчик" выделится? Дело в том, что на этом форуме есть проблема - символ CHR(160) автоматически меняются на пробел CHR(32). В Ваших данных ранее уже было одно значение, где вместо пробела использовался CHR(160) В конце моего сообщения #6 есть предупреждение: Изменено: ZVI - 22 Июл 2019 07:32:32 (CHR(160) не вставляется в код на форуме!) И в коде #6 есть строка с комментарием: Const Pattern1 = "[ ,\. ]"' 1-й символ это CHR(160), последний - пробел В коде для Const Pattern1 удалите первый символ после открывающей квадратной скобки "[" и в позиции удаленного символа нажмите и удерживайте Alt и на цифровой клавиатуре (та, что справа) введите 0160 затем отпустите ALT.
Function FirstNoun$(s$)
Const BadEnd$ = "ая ий ый ое ой ее яя ьи ые ся"
Dim re, ms, m
Set re = CreateObject("VBScript.RegExp"): re.Pattern = "([А-ЯЁ]?[а-яё-]+).?": re.Global = True
If re.test(s) Then
Set ms = re.Execute(s)
For Each m In ms
If Len(m) > 2 And Right(m, 1) <> "." Then
If InStr(BadEnd, Right(m.submatches(0), 2)) = 0 Then FirstNoun = m.submatches(0): Exit Function
End If
Next
End If
End Function
Sub Nouns() ' Исходные в колонке 4(D), результаты в колонке 7(G)
Const BadEnd$ = "ая ий ый ое ой ее яя ьи ые ся"
Dim re, ms, m, ar, r&, s$
Set re = CreateObject("VBScript.RegExp"): re.Pattern = "([А-ЯЁ]?[а-яё-]+).?": re.Global = True
ar = Intersect(ActiveSheet.UsedRange, Columns(4)): ar(1, 1) = "Имя существительное"
For r = 2 To UBound(ar)
s = ar(r, 1)
If re.test(s) Then
Set ms = re.Execute(s)
For Each m In ms
If Len(m) > 2 And Right(m, 1) <> "." Then
If InStr(BadEnd, Right(m.submatches(0), 2)) = 0 Then ar(r, 1) = m.submatches(0): Exit For
End If
Next
End If
If ar(r, 1) = s Then ar(r, 1) = ""
Next
Cells(1, 7).Resize(UBound(ar), 1) = ar
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Правило для 2-й строки тогда изменилось, пробуйте такой вариант:
Код
Sub Main()
Const MinLength = 4 ' Мин. длина слова в символах
Const ExcludeList = "ая,ый,ое,ий,ой,ые,яя,ся,ее" ' Окончания игнорируемых слов
Const Pattern1 = "[\u00A0,\.\/ ]" ' 1-й символ это CHR(160), последний - пробел
Const Pattern2 = "\b_([А-ЯЁ\-]{" & MinLength & ",})[( ]"
Dim i As Long, a() As Variant, Obj As Object, Rng As Range, s As String
' Задать диапазон входных данных
With ThisWorkbook.Sheets(1)
Set Rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
End With
a() = Rng.Value
' Найти первое русское слова по шаблону
With CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = True
For i = 1 To UBound(a)
s = Trim(a(i, 1))
If Len(s) = 0 Then
a(i, 1) = Empty
Else
a(i, 1) = "(нет)"
' --> Исключения из правил
If InStr(1, s, "душ", 1) = 1 Then
a(i, 1) = "душ"
Else
'If InStr(1, s, "хром", 1) > 0 Then s = Replace(s, "хром", "", Compare:=1)
' <-- Конец исключений
.Pattern = Pattern1
s = .Replace(s, " _")
.Pattern = Pattern2
For Each Obj In .Execute("_" & s & " ")
s = LCase(Obj.SubMatches(0))
If InStr(ExcludeList, Right(s, 2)) = 0 Then
a(i, 1) = s
Set Obj = Nothing
Exit For
End If
Next
End If
End If
Next
End With
' Поместить результат в столбец [h]
Rng.EntireRow.Columns("h").Value = a()
End Sub
Ранее наличие слова "душ" означало результат = "душ", или другое слово, если найдется, сейчас же только первое слово "душ" приводит к результату "душ". Подозреваю, что со сменой правила что-то в результатах может и нарушиться - пишите подробнее, что нужно или приведите больше данных, на которых проявляются проблемы.
Sub Main()
Const MinLength = 4 ' Мин. длина слова в символах
Const ExcludeList = "ая,ый,ое,ий,ой,ые,яя,ся,ее" ' Окончания игнорируемых слов
Const Pattern1 = "[\u00A0,\.\/ ]" ' 1-й символ это CHR(160), последний - пробел
Const Pattern2 = "\b_([А-ЯЁ\-]{" & MinLength & ",})[( ]"
Dim i As Long, j As Long, a() As Variant, Obj As Object, Rng As Range, s As String
' Задать диапазон входных данных
With ThisWorkbook.Sheets(1)
Set Rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
End With
a() = Rng.Value
' Найти первое русское слова по шаблону
With New RegExp ' CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = True
For i = 1 To UBound(a)
s = Trim(a(i, 1))
If Len(s) = 0 Then
a(i, 1) = Empty
Else
a(i, 1) = "(нет)"
' --> Исключения из правил
j = InStr(1, s, "душ", 1)
If j > 0 Then a(i, 1) = "душ"
'If InStr(1, s, "хром", 1) > 0 Then s = Replace(s, "хром", "", Compare:=1)
' <-- Конец исключений
.Pattern = Pattern1
s = .Replace(s, " _")
.Pattern = Pattern2
For Each Obj In .Execute("_" & s & " ")
s = LCase(Obj.SubMatches(0))
If InStr(ExcludeList, Right(s, 2)) = 0 Then
If j Then
If Obj.FirstIndex < j Then a(i, 1) = s
Else
a(i, 1) = s
End If
Exit For
End If
Next
End If
Next
Set Obj = Nothing
End With
' Поместить результат в столбец [h]
Rng.EntireRow.Columns("h").Value = a()
End Sub
ZVI, спасибо - последний вариант сработал даже совместно белого с черным списком With New RegExp ' CreateObject("VBScript.RegExp") заменил , единственное что сделал в посл макросе, на With CreateObject("VBScript.RegExp") Иначе была ошибка