Частотность слов в word - VBA

Sub Частота_основ()              ' cyberforum.ru > KoGG > Sasha_Smirnov > KoGG
    Const freq% = 1              ' частота появления слова, больше которой оно учитывается
    Const OsnovaLen% = 2         ' Минимальная длина несокращаемой основы слова
    Dim i&, j&, Lent%, dic As Object, vX As Variant, S$
    Dim vesText As String       ' переменная для всего текста
    Dim Slova                   ' переменная для массива слов
    Dim Ok                      ' переменная для массива окончаний
    Dim t As String             ' переменная для текста очередного "слова"
    ' Массив удаляемых окончаний, массив упорядочен от 3 буквенных до 1 буквенных :
    Ok = Split("АМИ ЕМИ ЕМЯ ЁТЕ ЕТЕ ЁШЬ ЕШЬ ИМИ ИТЕ ИШЬ ОМУ ОГО УМЯ ЫМИ ЫТЕ ЫШЬ АМ АС АТ AX АЯ ЕЕ ЕЁ ЕЙ ЕМ EX ЕЮ ЁТ ЕТ ЁХ ЕХ ИИ ИЕ ИЙ ИМ ИТ ИХ ИЮ ЫИ ЫЕ ЫЙ ЫМ ЫТ ЫХ ЫЮ МИ МЯ ОВ ОЕ ОЁ ОЙ ОМ ОЮ УМ УТ УХ УЮ ШЬ ЬЕ ЬЁ ЬЮ ЬЯ А Е Ё И О У Ы Ь Ю Я", " ")
    ' Массив длин окончаний
    Dim k%(): ReDim k(UBound(Ok)): For i = 0 To UBound(Ok): k(i) = Len(Ok(i)): Next
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    With dic
        .CompareMode = 1   ' Отключение чувствительности к регистру в словаре.
        vesText = ActiveDocument.Range.Text
        vesText = Replace$(vesText, vbCr, " ")
        vesText = Replace$(vesText, vbLf, " ")
        vesText = Replace$(vesText, vbTab, " ")
        vesText = Replace(vesText, Chr$(160), " ", , , vbBinaryCompare) ' Неразрывный пробел
        vesText = Replace$(vesText, "  ", " ") ' 2 пробела на 1
        vesText = Replace$(vesText, "  ", " ") ' еще раз - уменьшится массив
        vesText = Replace$(vesText, "  ", " ") ' еще раз
        Slova = Split(vesText, " ")
        vesText = ""
        For i = 0 To UBound(Slova)
           t = Slova(i)
           If t <> "" Then
                Select Case Asc(UCase$(Right$(t, 1))) ' Проверяем , является буквой или цифрой последний символ слова
                    Case 48 To 57               '  цифры
                    Case 65 To 90, 168, 184, 192 To 223    '  ЗАГЛ. буквы
                    Case Else: t = Left$(t, Len(t) - 1) ' Если нет, то обрезаем последний символ
                End Select
           End If
           If t <> "" Then
                S = UCase$(t)
                Select Case Asc(S)
                    Case 48 To 57: .Item(t) = .Item(t) + 1 '  цифры
                    Case 65 To 90: .Item(t) = .Item(t) + 1 '  ЗАГЛ. латинские буквы
                    Case 168, 184, 192 To 223  '  ЗАГЛ. буквы кириллицы
                        ' Перебираем и удаляем окончания
                        For j = 0 To UBound(Ok)
                            Lent = Len(t)
                            If Lent >= OsnovaLen + k(j) Then
                                If Right$(S, k(j)) = Ok(j) Then
                                    t = Left$(t, Lent - k(j))
                                    Exit For
                                End If
                            End If
                        Next j
                        .Item(t) = .Item(t) + 1
                End Select
           End If
        Next
        Documents.Add: ActiveWindow.ActivePane.View.Type = wdPrintView  ' вид "Разметка страницы"
        For Each vX In .Keys
            If .Item(vX) > freq Then Selection.TypeText vX & Chr(9) & .Item(vX) & Chr(13)
        Next
    End With
    Set dic = Nothing
    Erase Slova
    With Selection: .Sort: .Collapse: .Delete: End With     ' Сортировка по алфавиту.
    ActiveDocument.PageSetup.TextColumns.SetCount NumColumns:=4 ' В 4 колонки.
    ActiveDocument.PageSetup.TextColumns.LineBetween = True     ' Линии между колонок.
    ActiveDocument.Paragraphs.TabStops.Add CentimetersToPoints(3.5), wdAlignTabRight
End Sub