Как определить количество неповторяющихся слов в документе - VBA
Формулировка задачи:
Здравствуйте, как известно, в документе Word (моя версия - 2010) есть статистика, которая показывает количество символов (всего) в документе.
А есть ли такое внутреннее средство Word (или сторонняя программа), которое бы позволило узнать сколько в документе именно слов, причём слов не повторяющихся (если в документе слово, например, "молоко" встречается 10 раз, то учитывалось бы только одно использование)?
И было бы неплохо, чтобы это средство (или прога) составила список всех (не повторяющихся) слов, использованных в документе.
Если что-то подобное есть, подскажите, пожалуйста! Буду весьма признателен!
Решение задачи: «Как определить количество неповторяющихся слов в документе»
textual
Листинг программы
Sub Частота_слов() ' cyberforum.ru > KoGG > Sasha_Smirnov-30.9.2015
Const freq = 1 ' частота появления слова в тексте, начиная с которой оно учитывается в словаре
Dim oWord As Range, dic As Object, vX As Variant, S As String
Dim t As String ' переменная для текста очередного "слова" (oWord.Text)
Set dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With dic
.CompareMode = 0 ' чувствительность к регистру символов при подсчёте слов [1=выкл.]
For Each oWord In ActiveDocument.Range.Words
t = oWord.Text
t = Replace(t, Chr(160), Space(1)) ' замена в слове t неразр. пробела на пробел '|
While InStr(t, Space(2)) '|
t = Replace(t, Space(2), Space(1)) ' замена в слове t двух и > пробелов на один '|
Wend '|
If Not Right(t, 1) Like "[ " & Chr(10) & Chr(11) & Chr(13) & "]" Then t = t & " "
S = UCase(t)
Select Case Asc(S)
Case 48 To 57, 65 To 90, 168, 184, 192 To 223 ' цифры и ЗАГЛ. буквы
.Item(t) = .Item(t) + 1
End Select
Next
Documents.Add: ActiveWindow.ActivePane.View.Type = wdPrintView ' вид "Разметка страницы"
For Each vX In .Keys
If .Item(vX) >= freq Then Selection.TypeText RTrim(vX) & Chr(9) & .Item(vX) & Chr(13)
Next
End With
With Selection: .Sort: .Collapse: .Delete: End With ' Сортировка слов по алфавиту.
ActiveDocument.PageSetup.TextColumns.SetCount NumColumns:=4 ' В 4 колонки.
ActiveDocument.PageSetup.TextColumns.Spacing = CentimetersToPoints(2) ' 20 мм между колонок
ActiveDocument.PageSetup.TextColumns.LineBetween = True ' Линии между колонок.
With ActiveDocument 'установка полей; нумерация строк
With .PageSetup
.TopMargin = CentimetersToPoints(1)
.BottomMargin = CentimetersToPoints(1)
.LeftMargin = CentimetersToPoints(0.9)
.RightMargin = CentimetersToPoints(0)
.LineNumbering.Active = True ' нумерация строк словаря (не слов! слово может и 2 строки занять)
.LineNumbering.RestartMode = wdRestartContinuous ' сплошная нумерация строк
.LineNumbering.DistanceFromText = 1.5 'pt
End With
.Paragraphs.TabStops.Add CentimetersToPoints(3.3), wdAlignTabRight ' таб 33 мм c выравниванием вправо
End With
Set dic = Nothing 'Борис_Р, cyberforum.ru
End Sub