Статьи из блога
Статьи из блога
Макрос для подсчета частоты упоминаемых слов
Метки: макросы
Суббота, 8 августа 2009 г.
Просмотров: 3430
Подписаться на комментарии по RSS
Версия для печати
Андрей задал вопрос:
Мой начальник дал такое задание: нужно определить в разных документах частоту упоминаемых слов. Причем не отдельно выбранного слова, а именно сколько раз какое слово встречается. Если дадите готовое решение, буду очень благодарен.
Андрей, у меня есть нужный вам макрос с функцией. Но писал его не я, а по моей просьбе иноязычный товарищ (дело было в августе прошлого года). Вставляет в конце каждого упоминаемого слова в скобках количество его вхождений в тексте.
Правда, макрос вставляет и лишние символы (да и вообще, может быть избыточный код в нем). Просто скопируйте весь код в редактор 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

Поиск
Рубрики
Подписка
Читают
Обсуждают
Форум
страницы
сайты
статистика
Комментариев: 1
Здравствуйте. Очень пригодился данный макрос. Но нельзя ли "научить его" отсекать окончания, чтоб, допустим, мог подсчитать все "народ#", скажем, вместе, сколько раз встречается, а не раздельно сколько раз: "народ", "народу", "народам", "народу" и .т.п.
Спасибо, заранее!