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

Формулировка задачи:

Здравствуйте, уважаемые программисты! Нуждаюсь в Вашей доброй помощи. Моей девушке (лингвисту-переводчику) на последнем курсе ввели новую дисциплину "основы программирования", зачем это сделали для гуманитария,- не понятно Естественно она в этом не бум бум, ну и я тоже. Нуждаемся в Вашем совете и помощи! Задание следующие, преподаватель сказал, что им нужно разработать программу на vba по определению частотности основных слов и словосочетаний в ее дипломе, который она сейчас пишет в ворде 2007. Дала две книги по 300-400 страниц и сказала, что через три недели прогу надо сдать, для нас гуманитариев это конец, мы в этих книгах ничего не понимаем. Прошу большой помощи!

Решение задачи: «Частотность слов в word»

textual
                            Листинг программы 
                        

                            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
                        