Макрос для подсчета частоты упоминаемых слов

Андрей задал вопрос:

Андрей, у меня есть нужный вам макрос с функцией. Но писал его не я, а по моей просьбе иноязычный товарищ (дело было в августе прошлого года). Вставляет в конце каждого упоминаемого слова в скобках количество его вхождений в тексте.

Правда, макрос вставляет и лишние символы (да и вообще, может быть избыточный код в нем). Просто скопируйте весь код в редактор VB для Word-а и запустите.

Если вы не знаете, как подключить к документу и применить эти макросы, изучите следующие заметки с сайта:

Создание макроса из готового кода

Автоматическая запись макроса

Sub WordFrequencyCounter()
    Dim WordList() As String
    Dim WordCount() As Long
    Dim nWords As Long
    Dim Index As Long
    Dim actDoc As Document
    Dim oRange As Range
    Dim aWord As Object
    Dim sWord As String
    Dim i As Long
    ReDim WordList(1)
    ReDim WordCount(1)
    WordList(1) = ""
    WordCount(1) = 0
    nWords = 0
    Set actDoc = ActiveDocument
'
' Count every word in the ActiveDocument
'
    For Each aWord In actDoc.Words
        sWord = Trim(aWord.Text)
        If IsOnlyPunctuation(sWord) Then sWord = ""
        If Len(sWord) > 0 Then
            Index = 1
            While (Index > 0 And Index <= nWords)
                If StrComp(WordList(Index), sWord, vbTextCompare) = 0 Then
                    WordCount(Index) = WordCount(Index) + 1
                    Index = 0
                Else
                    Index = Index + 1
                End If
            Wend
            If Index > 0 Then
                If nWords = 0 Then
                    nWords = 1
                Else
                    nWords = nWords + 1
                    Application.StatusBar = "Counting Tokens in Document: " & nWords
                    ReDim Preserve WordList(nWords)
                    ReDim Preserve WordCount(nWords)
                End If
                WordList(nWords) = sWord
                WordCount(nWords) = 1
            End If
        End If
    Next aWord
'
' Add Frequency to every word in the ActiveDocument
'
    For i = actDoc.Words.Count To 1 Step -1
        Set oRange = actDoc.Words(i)
        sWord = Trim(oRange.Text)
        If IsOnlyPunctuation(sWord) Then sWord = ""
        If Len(sWord) > 0 Then
            Index = 1
            While (Index > 0 And Index <= nWords)
                If StrComp(WordList(Index), sWord, vbTextCompare) = 0 Then
                    '
                    'Found it
                    oRange.InsertAfter " (" & WordCount(Index) & ") "
                    Index = 0
                Else
                    Index = Index + 1
                End If
            Wend
        End If
    Next i
End Sub
' IsOnlyPunctuation
' Returns true only if every character in a word string is punctuation
'
Private Function IsOnlyPunctuation(ByVal sWord As String) As Boolean
    Dim sPunctuation As String
    Dim sChar As String
    Dim nIndex As Long
    sPunctuation = " .,?';:![]{}()-_" & Chr(9) & Chr(10) & Chr(11) & Chr(12) & Chr(13) & Chr(14) & _
    Chr(34) & Chr(145) & Chr(146) & Chr(147) & Chr(148) & Chr(150) & Chr(151) & Chr(160)
    nIndex = 1
    While (nIndex <= Len(sWord))
        sChar = Mid(sWord, nIndex, 1)
        If InStr(1, sPunctuation, sChar, vbBinaryCompare) = 0 Then
            IsOnlyPunctuation = False
            Exit Function
        End If
        nIndex = nIndex + 1
    Wend
    IsOnlyPunctuation = True
End Function