Страницы: 1 2 След.
RSS
Как из текста при получении русского слова исключить слова, содержащие в конце слова ая или ый или ое?, в продолжение темы "Как из текста-каши получить первое русское слово"
 
Как из текста при получении русского слова (уже реализовано в теме "Как из текста-каши получить первое русское слово") исключить слова , содержащие в конце слова ая или ый или ое?
Код
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 - 21.07.2019 08:59:14
 
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)
…
Модераторам: название темы «Исключить из выбора слова с определёнными окончаниями»
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Так у Вас практически все слова заканчиваются на эти самые ~ая(ый) (столбец F)
В чем подвох?
Изменено: Sanja - 21.07.2019 09:20:37
Согласие есть продукт при полном непротивлении сторон
 
Sanja, не получает в вашем примере первое русское слова без окончания "ая" . Надо из текста "Душевая колонна" получить результат: "колонна"
Jack Famous, можно показать в примере конкретно моего макроса в приложении?
Изменено: getana - 21.07.2019 09:48:26
 
Понятно. Тогда нужно извлекать все русские слова, а уже потом, в полученном результате, искать первое без этих окончаний
Согласие есть продукт при полном непротивлении сторон
 
Вариант для текущего и добавленного к нему предыдущего списка
Код
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, надо исключить не конкретные слова, а все слова с окончаниями "ая" "ый" "ое" . А то список с такими окончаниями в разных прайсах может быть огромен!
Изменено: getana - 21.07.2019 09:53:38
 
Цитата
getana написал: надо исключить не конкретные слова
Вы код запускали?
 
ZVI, не заметил первые строки, спасибо - попробую от пишусь . Вы как я понял сделали 2 варианта на выбор: и исключить с окончаниями и исключить какие то др слова дополнительно.  
 
Фрагмент кода "Исключения из правил" не принципиальный, его можно исключить, он исправляет всего лишь несколько не очень точных результатов из всего списка.
 
Цитата
getana: можно показать в примере конкретно моего макроса в приложении?
В примере ВАШЕГО — нет, но ПО ТЕМЕ вот готовый макрос
Изменено: Jack Famous - 21.07.2019 10:58:16 (UPD: теперь удаляет "мусор" в конце строки в виде точек, запятых и т.д.)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
А как насчет большой, синий, синее, синяя, третья, третье...
Владимир
 
ZVI, идеальная работа - быстро, качественно и все по делу. Спасибо, все работает на 100% пост #6 . Изначально и не рассчитывал, что до идеализма можно все довести...
 
Да, разумеется, для идеала нужны словари, таблицы Зализняка и т.п. :)  
Изменено: sokol92 - 21.07.2019 19:46:09
Владимир
 
Цитата
getana написал:  Спасибо, все работает на 100% пост #6
Пожалуйста :)

Цитата
sokol92 написал: ... для идеала нужны словари, таблицы Зализняка и т.п. :)
Владимир, в идеале - да, а у меня решение просто подогнано  под конкретные данные ;) Ну, и маленький трюк придуман с "\b", чтобы работало не только с англо-словами.
Изменено: ZVI - 21.07.2019 20:58:06
 
sokol92, приветствую! Если это вы мне, то какой вопрос (от ТС) - такой и ответ))
список исключаемых окончаний легко правится в строке №47 кода — For Each x In Array("ая", "ое", "ый")  :)
Изменено: Jack Famous - 22.07.2019 08:41:40
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Jack Famous написал:
Если это вы мне,
Здравствуйте, Алексей! Мой вопрос, конечно же, был к автору темы, он уже ответил.

Цитата
ZVI написал:
маленький трюк придуман с "\b",
Здравствуйте, Владимир! Я заметил :)  
Владимир
 
Base шкафчик 665х440х530 мм, с 2 ящ   -   почему то не получает слово шкафчик ?!
Изменено: getana - 22.07.2019 21:36:32
 
Цитата
getana написал: Base шкафчик 665
У меня работает. Вот если бы Вы приложили 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.
 
Владимир, можно записать так (объяснять дольше): :)

Код
Const Pattern1 = "[\u00A0,\. ]"
Владимир
 
ZVI, sokol92, спасибо - сработало
 
Код
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
Изменено: Ігор Гончаренко - 24.07.2019 02:22:03
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Код
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
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко,  Игорь ."ая ий ый ое ой ее яя ьи ые ся"  Опечатка? "ся" - это от куда и нет "ие"
Изменено: БМВ - 24.07.2019 07:39:32
По вопросам из тем форума, личку не читаю.
 
как раз эту часть кода может легко исправить каждый)
ие - конечно нужно добавить
ся - это реакция на "вращающаяся"
Изменено: Ігор Гончаренко - 24.07.2019 11:32:44
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Ігор Гончаренко написал:
"вращающаяся"
ну да, а еще есть лисья шуба :-) , в общем место для творчества :-)
По вопросам из тем форума, личку не читаю.
 
ZVI, https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=119086&a...

заметил что первое слово из исключения (белый список) не учитывается как первое, которое надо найти. Привожу пример в прикрепленном файле  
Изменено: getana - 13.11.2019 00:39:41
 
Правило для  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

Ранее наличие слова "душ" означало результат = "душ", или другое слово, если найдется, сейчас же только первое слово "душ" приводит к результату "душ".
Подозреваю, что со сменой правила что-то в результатах может и нарушиться - пишите подробнее, что нужно или приведите больше данных, на которых проявляются проблемы.
Изменено: ZVI - 13.11.2019 01:07:05
 
Предполагаю, что все-таки так будет лучше:
Код
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")
Иначе была ошибка
Изменено: getana - 13.11.2019 08:37:44
Страницы: 1 2 След.
Наверх