[Iska]

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

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

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

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

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

[Drongo]

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

Возможно подразумевалось не учитывать в подсчётах? Тогда исключить длину слова равную 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

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