Статьи из блога

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

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

Мой начальник дал такое задание: нужно определить в разных документах частоту упоминаемых слов. Причем не отдельно выбранного слова, а именно сколько раз какое слово встречается. Если дадите готовое решение, буду очень благодарен.

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

Правда, макрос вставляет и лишние символы (да и вообще, может быть избыточный код в нем). Просто скопируйте весь код в редактор 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
twitter.com facebook.com vkontakte.ru odnoklassniki.ru mail.ru ya.ru rutvit.ru myspace.com technorati.com digg.com friendfeed.com pikabu.ru blogger.com liveinternet.ru livejournal.ru memori.ru google.com bobrdobr.ru mister-wong.ru yahoo.com yandex.ru del.icio.us
Вы можете помочь в развитии сайта, сделав пожертвование:

Или помочь сайту популярной криптовалютой:

 

BTC Адрес: 1Pi3a4c6sJPbfF2sSYR2noy61DMBkncSTQ

 

ETH Адрес: 0x7d046a6eaa1bd712f7a6937b042e9eee4998f634

 

LTC Адрес: LUyT9HtGjtDyLDyEbLJZ8WZWGYUr537qbZ

 

DOGE Адрес: DENN2ncxBc6CcgY8SbcHGpAF87siBVq4tU

 

BAT Адрес: 0x7d046a6eaa1bd712f7a6937b042e9eee4998f634

 

XRP Адрес: rEb8TK3gBgk5auZkwc6sHnwrGVJH8DuaLh Депозит Tag: 105314946

 

USDT (ERC-20) Адрес: 0x7d046a6eaa1bd712f7a6937b042e9eee4998f634

 

Яндекс Деньги: 410013576807538

 

Вебмани (R ещё работает): R140551758553 или Z216149053852

 

А тут весь список наших разных крипто адресов, может какой добрый человек пожертвует немного монет или токенов - получит плюсик в карму от нас :) Благо Дарим, за любую помощь!

 

Еще записи по вопросам использования Microsoft Word:

Комментариев: 2

  1. Алмат
    13.05.2010 в 23:16 | #1

    Здравствуйте. Очень пригодился данный макрос. Но нельзя ли "научить его" отсекать окончания, чтоб, допустим, мог подсчитать все "народ#", скажем, вместе, сколько раз встречается, а не раздельно сколько раз: "народ", "народу", "народам", "народу" и .т.п.

    Спасибо, заранее!

  2. Юлия
    09.05.2013 в 22:35 | #2

    Добрый вечер!

    А подскажите код для подсчет буквы "а" (к примеру) во всем документе

Оставьте комментарий!

(обязательно)

^ Наверх