Страницы: Пред. 1 2
RSS
Как из текста при получении русского слова исключить слова, содержащие в конце слова ая или ый или ое?, в продолжение темы "Как из текста-каши получить первое русское слово"
 
в посл примере внесен 1 товар в белый список, а как внести два и больше?:
Код
        j = InStr(1, s, "душ", 1)
        If j > 0 Then a(i, 1) = "душ"
 
Так как примера данных нет - тестируйте сами:
Код
Sub Main()
 
  Const MinLength = 4                 ' Мин. длина слова в символах
  Const GoodList = "душ,муж,куш"      ' Список (белый) допустимых русских словё длиной <  MinLength
  Const ExcludeList = "ая,ый,ое,ий,ой,ые,яя,ся,ее"  ' Окончания игнорируемых слов
  Const Pattern1 = "[\u00A0,\.\/ ]"   ' 1-й символ это CHR(160), последний - пробел
  Const Pattern2 = "\b_([А-ЯЁ\-]*)[( ]"
 
  Dim i As Long, a() As Variant, Obj As Object, Rng As Range, s As String
  Dim Dic As Object, w As Variant
    
  ' Задать диапазон входных данных
  With ThisWorkbook.Sheets(1)
    Set Rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
  End With
  a() = Rng.Value
   
  ' Создать словарь слов белого списка
  Set Dic = CreateObject("Scripting.Dictionary")
  With Dic
    For Each w In Split(GoodList, ",")
      .Item(Trim(w)) = Empty
    Next
  End With
   
  ' Найти первое русское слова по шаблону
  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 s = Replace(s, "хром", "", Compare:=1)
        ' <-- Конец удаления
        .Pattern = Pattern1
        s = .Replace(s, " _")
        .Pattern = Pattern2
        For Each Obj In .Execute("_" & s & " ")
          s = LCase(Obj.SubMatches(0))
          If Len(s) < MinLength Then
            If Dic.Exists(s) Then
              a(i, 1) = s
              Exit For
            End If
          ElseIf InStr(1, ExcludeList, Right(s, 2), vbTextCompare) = 0 Then
            a(i, 1) = s
            Exit For
          End If
        Next
      End If
    Next
    Set Obj = Nothing
    Set Dic = Nothing
  End With
 
  ' Поместить результат в столбец [e]
  Rng.EntireRow.Columns("e").Value = a()
  
End Sub
Изменено: ZVI - 13.11.2019 15:02:05
 
ZVI, не работает белый список. В приложении образец для проверки. Посмотрите, пож-та, в чем проблема...
Изменено: getana - 13.11.2019 15:46:27
 
Цитата
getana написал: не работает белый список
Вы прочитайте, что написано в комментарии к списку:
' Список (белый) допустимых русских слов длиной <  MinLength
А у вас там слово длиннее MinLength.
Потом, наверное, еще окажется, что не только русских слов ))
Опишите правило для этого списка, от него же код меняется радикально.
И в примере приведите, что ожидается
 
Вот код для "белого" списка с русскими словами любой длины:
Код
Sub Main()
  
  Const MinLength = 4                 ' Мин. длина слова в символах
  Const GoodList = "гостиная,душевая" ' Список (белый) допустимых русских слов
  Const ExcludeList = "ая,ый,ое,ий,ой,ые,яя,ся,ее"  ' Окончания игнорируемых слов
  Const Pattern1 = "[\u00A0,\.\/ ]"   ' 1-й символ это CHR(160), последний - пробел
  Const Pattern2 = "\b_([А-ЯЁ\-]*)[( ]"
  
  Dim i As Long, a() As Variant, Obj As Object, Rng As Range, s As String
  Dim Dic As Object, w As Variant
     
  ' Задать диапазон входных данных
  With ThisWorkbook.Sheets(1)
    Set Rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
  End With
  a() = Rng.Value
    
  ' Создать словарь слов белого списка
  Set Dic = CreateObject("Scripting.Dictionary")
  With Dic
    For Each w In Split(GoodList, ",")
      .Item(Trim(w)) = Empty
    Next
  End With
    
  ' Найти первое русское слова по шаблону
  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 s = Replace(s, "хром", "", Compare:=1)
        ' <-- Конец удаления
        .Pattern = Pattern1
        s = .Replace(s, " _")
        .Pattern = Pattern2
        For Each Obj In .Execute("_" & s & " ")
          s = LCase(Obj.SubMatches(0))
          If Dic.Exists(s) Then
            a(i, 1) = s
            Exit For
          End If
          If InStr(1, ExcludeList, Right(s, 2), vbTextCompare) = 0 Then
            a(i, 1) = s
            Exit For
          End If
        Next
      End If
    Next
    Set Obj = Nothing
    Set Dic = Nothing
  End With
  
  ' Поместить результат в столбец [q]
  Rng.EntireRow.Columns("q").Value = a()
   
End Sub
Изменено: ZVI - 13.11.2019 16:22:19
 
ZVI, Список (белый) допустимых русских слов  -  надо белый список сделать не зависимо, русские или смешанные в составе слова буквы или символы. Потому что очень часто в названия вставляют английские буквы. Например, "Мойкa" с посл буквой "a" не русской. Можете подкорректировать код?
Еще заметил, что последний код не ограничивает минимальное количество символов в русском слове!
Изменено: getana - 13.11.2019 19:16:03
 
Пора, наверное,  Вам уже немного VBA подучить, чтобы уметь самостоятельно подгонять код под некоторые несложные нюансы, например, учет минимальной длины.
Или прикладывать тестовые данные и желаемый результат, как предлагалось в конце сообщения 34.
Примера данных и ожидаемого результата так и нет, тестируйте сами:
Код
Sub Main()
   
  Const MinLength = 4                 ' Мин. длина слова в символах
  Const GoodList = "гостиная,душевая" ' Список (белый) допустимых слов
  Const ExcludeList = "ая,ый,ое,ий,ой,ые,яя,ся,ее"  ' Окончания игнорируемых слов
  Const Pattern1 = "[\u00A0,\.\/ ]"   ' 1-й символ это CHR(160), последний - пробел
  Const Pattern2 = "\b_([abcekmnhoptuyА-ЯЁ\-]*)[( ]" ' "abcekmnhoptuy" - нерусские буквы, которые могут выглядеть как русские
   
  Dim i As Long, a() As Variant, Obj As Object, Rng As Range, s As String
  Dim Dic As Object, w As Variant
      
  ' Задать диапазон входных данных
  With ThisWorkbook.Sheets(1)
    Set Rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
  End With
  a() = Rng.Value
     
  ' Создать словарь слов белого списка
  Set Dic = CreateObject("Scripting.Dictionary")
  With Dic
    .CompareMode = 1
    For Each w In Split(GoodList, ",")
      .Item(Trim(w)) = Empty
    Next
  End With
     
  ' Найти первое русское слова по шаблону
  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 s = Replace(s, "хром", "", Compare:=1)
        ' <-- Конец удаления
        .Pattern = Pattern1
        s = .Replace(s, " _")
        .Pattern = Pattern2
        For Each Obj In .Execute("_" & s & " ")
          s = LCase(Obj.SubMatches(0))
          If Dic.Exists(s) Then
            a(i, 1) = s
            Exit For
          End If
          If Len(s) >= MinLength Then
            If s Like "*[а-яё]*" Then
              If InStr(1, ExcludeList, Right(s, 2), vbTextCompare) = 0 Then
                a(i, 1) = s
                Exit For
              End If
            End If
          End If
        Next
      End If
    Next
    Set Obj = Nothing
    Set Dic = Nothing
  End With
   
  ' Поместить результат в столбец [q]
  Rng.EntireRow.Columns("q").Value = a()
    
End Sub
Изменено: ZVI - 13.11.2019 19:49:23
 
Цитата
ZVI написал:
Пора, наверное,  Вам уже немного VBA подучить
Владимир, вот и Вашему терпению приходит конец :-).

getana, Я не зарабатываю на жизнь ни программированием, ни решениями в Excel, но однозначно уверен, что такие вот спиралевидные вопросы, обесценивают труд специалистов. ибо это уже не отдельный вопрос, а комплексная задача, с которой самостоятельно вы не можете справится, но получить платную помощь не готовы.  Каша из топора получается, а не Как из текста-каши получить первое русское слово
Изменено: БМВ - 13.11.2019 19:58:04
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:Владимир, вот и Вашему терпению приходит конец :-)
Михаил, добрый вечер. Терпение-то есть ещё, чего не скажешь о желании заниматься догадками наобум без примеров  :)
Изменено: ZVI - 13.11.2019 20:06:24
 
ZVI, огромное спасибо!
 
Цитата
getana написал:  ZVI , огромное спасибо!
Пожалуйста  :)
Страницы: Пред. 1 2
Наверх