2013 - Анализ текста

[Invincible]

Цитата Invincible:



А нельзя добавить, чтобы учитывались падежи слов?

2013 - Анализ текста

Я не припоминаю такого функционала в комплекте Microsoft Office.




Цитата Invincible:



И еще союзы, предлоги, частицы удалить из текста, такие как "и", "а".

2013 - Анализ текста

И такого тоже.



Если «союзы, предлоги, частицы удалить из текста» ещё возможно теоретически (если Вы перечислите все возможные варианты «союзы, предлоги, частицы»), то конкурировать с десятками и сотнями тысяч человеко-лет крупных контор в лексическом анализе нереально.

[Drongo]

Цитата Invincible:



И еще союзы, предлоги, частицы удалить из текста, такие как "и", "а".

2013 - Анализ текста

Возможно подразумевалось не учитывать в подсчётах? Тогда исключить длину слова равную 1 символу в скрипте Iska. Однако это не выход и не решит задачи в целом. А насчёт падежей это по моему не получится, нужна как минимум база-словарь слов, да и то не факт что получится правильно распознать.

[Invincible]

Код:

Код: Выделить всё

Option Explicit
Sub Sample()
    Dim objWord As Range
    Dim strWord As String
    Dim objDictionary As Object
    Dim elem As Variant
    Dim strWord1 As String
    Dim strWord2 As String
    Dim i As Integer
    Set objDictionary = CreateObject("Scripting.Dictionary")
    For Each objWord In ThisDocument.Words
        strWord = RemoveNonAlpha(objWord.Text)
        If Not Len(strWord) = 0 Then
            If Not objDictionary.Exists(strWord) Then
                objDictionary.Add strWord, 1
            Else
                objDictionary.Item(strWord) = objDictionary.Item(strWord) + 1
            End If
        End If
    Next
    For Each elem In objDictionary.Keys
        Debug.Print "[" & elem & "]", objDictionary.Item(elem)
    Next
    objDictionary.RemoveAll
    Debug.Print "===================================================================="
    For i = 1 To ThisDocument.Words.Count - 1
        strWord1 = LCase(RemoveNonAlpha(ThisDocument.Words.Item(i).Text))
        strWord2 = LCase(RemoveNonAlpha(ThisDocument.Words.Item(i + 1).Text))
        If Len(strWord1) > 0 And Len(strWord2) > 0 Then
            If StrComp(strWord1, strWord2, vbTextCompare) = 1 Then
                strWord = strWord2 & " " & strWord1
            Else
                strWord = strWord1 & " " & strWord2
            End If
            If Not objDictionary.Exists(strWord) Then
                objDictionary.Add strWord, 1
            Else
                objDictionary.Item(strWord) = objDictionary.Item(strWord) + 1
            End If
        End If
    Next
    For Each elem In objDictionary.Keys
        Debug.Print "[" & elem & "]", objDictionary.Item(elem)
    Next
    objDictionary.RemoveAll
    Set objDictionary = Nothing
End Sub
Function RemoveNonAlpha(strValue As String) As String
    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        .Global = True
        .Multiline = True
        .Pattern = "([^a-zа-яё])*"
        RemoveNonAlpha = .Replace(strValue, "")
    End With
End Function

А что нужно изменить в этом макросе, чтобы учитывались три слова, стоящие рядом?