Анализ текста

[Invincible]

Всем привет.
Можете подсказать, можно в Word производить такой анализ текста: разбить текст на слова, посчитать количество повторяющихся слов в тексте, найти пары слов наиболее связанных друг с другом и посчитать их количество?

[Iska]

Invincible, можно. Макросом.

пары слов наиболее связанных друг с другом »
Что это значит?

[Invincible]

Что это значит? »
Пары слов, которые чаще всего встречаются, проще говоря их количество

[Invincible]

можно. Макросом. »
А у вас нету такого макроса? А то я в них не силен

[Iska]

Пары слов »
«Пару слов» понимать как стоящие рядом друг с другом? В строгом порядке или произвольном: «мама мыла» и «мыла мама» — это должно числиться как одна пара или как две разных пары?

А у вас нету такого макроса? »
Нет. Его надо написать.

Например, для первой части:
разбить текст на слова, посчитать количество повторяющихся слов в тексте, »
Option Explicit

Sub Sample()
Dim objWord As Range
Dim strWord As String
Dim objDictionary As Object
Dim elem As Variant


Set objDictionary = CreateObject("Scripting.Dictionary")

For Each objWord In ThisDocument.Words
strWord = Trim(Replace(objWord.Text, vbCr, ""))

If Not Len(strWord) = 0 Then
If Not objDictionary.Exists(strWord) Then
objDictionary.Add strWord, 1
Else
objDictionary.Item(strWord) = objDictionary.Item(strWord) + 1
End If
End If
Next

For Each elem In objDictionary.Keys
Debug.Print "[" & elem & "]", objDictionary.Item(elem)
Next
End Sub

Надо понимать, что у Word'а своё понимание понятия «слова», оно может быть отличным от Вашего. Например, данная страница может давать такой набор «слов»:
[Invincible] 6
[вне] 2
[форума] 2
[Старожил] 2
[Сообщения] 3
[:] 13
[171] 2
[Благодарности] 3
[1] 2
[ ] 3
[Профиль] 3
[|] 12
[Отправить] 3
[PM] 3
[Цитировать] 3
[Сообщить] 3
[модератору] 3
[Всем] 1
[привет] 1
[.] 3
[Можете] 1
[подсказать] 1
[,] 8
[можно] 2
[в] 2
[Word] 1
[производить] 1
[такой] 1
[анализ] 1
[текста] 1
[разбить] 1
[текст] 1
[на] 2
[слова] 1
[посчитать] 2
[количество] 3
[повторяющихся] 1
[слов] 4
[тексте] 1
[найти] 1
[пары] 2
[наиболее] 2
[связанных] 2
[друг] 2
[с] 2
[другом] 2
[и] 1
[их] 2
[?] 3
[Полезное] 1
[сообщение] 1
[Отправлено] 2
[23] 1
[28] 1
[Вчера] 1
[Iska] 3
[сейчас] 1
[форуме] 1
[Ветеран] 1
[Contributor] 1
[14335] 1
[4358] 1
[Редактировать] 1
[Макросом] 1
[Цитата] 2
[»] 2
[Что] 2
[это] 2
[значит] 2
[09] 1
[57] 1
[Сегодня] 1
[#] 1
[2] 1
[Автор] 1
[темы] 1
[Пары] 1
[которые] 1
[чаще] 1
[всего] 1
[встречаются] 1
[проще] 1
[говоря] 1

[Invincible]

«мама мыла» и «мыла мама» — это должно числиться как одна пара или как две разных пары? »
Как одна пара слов

[Iska]

Invincible, давайте попробуем так:
Option Explicit

Sub Sample()
Dim objWord As Range

Dim strWord As String
Dim objDictionary As Object
Dim elem As Variant

Dim strWord1 As String
Dim strWord2 As String
Dim i As Integer


Set objDictionary = CreateObject("Scripting.Dictionary")

For Each objWord In ThisDocument.Words
strWord = RemoveNonAlpha(objWord.Text)

If Not Len(strWord) = 0 Then
If Not objDictionary.Exists(strWord) Then
objDictionary.Add strWord, 1
Else
objDictionary.Item(strWord) = objDictionary.Item(strWord) + 1
End If
End If
Next

For Each elem In objDictionary.Keys
Debug.Print "[" & elem & "]", objDictionary.Item(elem)
Next

objDictionary.RemoveAll


Debug.Print "===================================================================="


For i = 1 To ThisDocument.Words.Count - 1
strWord1 = LCase(RemoveNonAlpha(ThisDocument.Words.Item(i).Text))
strWord2 = LCase(RemoveNonAlpha(ThisDocument.Words.Item(i + 1).Text))

If Len(strWord1) > 0 And Len(strWord2) > 0 Then
If StrComp(strWord1, strWord2, vbTextCompare) = 1 Then
strWord = strWord2 & " " & strWord1
Else
strWord = strWord1 & " " & strWord2
End If

If Not objDictionary.Exists(strWord) Then
objDictionary.Add strWord, 1
Else
objDictionary.Item(strWord) = objDictionary.Item(strWord) + 1
End If
End If
Next

For Each elem In objDictionary.Keys
Debug.Print "[" & elem & "]", objDictionary.Item(elem)
Next

objDictionary.RemoveAll
Set objDictionary = Nothing
End Sub

Function RemoveNonAlpha(strValue As String) As String
With CreateObject("VBScript.RegExp")
.IgnoreCase = True
.Global = True
.Multiline = True
.Pattern = "([^a-zа-яё])*"

RemoveNonAlpha = .Replace(strValue, "")
End With
End Function

Дополнительно будем удалять из «слов» Word'а все небуквенные символы, а то как-то больно нелепо смотрятся слова из знаков препинания, цифр, кавычек и т.п.

Пример для текста со страницы Темпы распространения Windows 10 за два месяца опережают Windows 7 (http://www.oszone.net/28236/Windows_10_Beats_Windows_7_in_Two-Month_Adoption_Race):
[популярной] 1
[из] 1
[когда] 1
[либо] 1
[выпущенных] 1
[операционных] 1
[систем] 1
[для] 2
[персональных] 1
[компьютеров] 1
[Поэтому] 1
[показатели] 1
[распространения] 2
[сравнивают] 1
[именно] 1
[с] 1
[ней] 1
[Статистика] 1
[от] 1
[NetMarketShare] 1
[показывает] 1
[что] 1
[в] 5
[первые] 1
[два] 2
[месяца] 2
[после] 3
[релиза] 1
[дела] 1
[идут] 1
[лучше] 1
[чем] 2
[у] 2
[за] 2
[аналогичный] 1
[промежуток] 1
[времени] 1
[У] 1
[результат] 2
[намного] 1
[ниже] 1
[как] 1
[наглядно] 1
[показано] 1
[графике] 1
[Доля] 2
[достигла] 1
[значения] 1
[против] 1
[привлекла] 1
[своё] 1
[время] 1
[внимание] 1
[только] 1
[Однако] 1
[демонстрировала] 1
[стабильные] 1
[результаты] 1
[течение] 1
[девяти] 1
[месяцев] 1
[чего] 1
[её] 1
[темпы] 1
[выросли] 1
[ещё] 1
[больше] 1
[а] 2
[во] 1
[второй] 1
[месяц] 1
[устанавливали] 1
[примерно] 1
[три] 1
[раза] 1
[меньше] 1
[первый] 1
[через] 1
[лет] 1
[появления] 1
[составляет] 2
[около] 1
[целью] 1
[распространение] 1
[млрд] 1
[устройств] 1
[пока] 1
[же] 1
[млн] 1
====================================================================
[операционная система] 1
[windows система] 1
[исправить призвана] 1
[исправить недостатки] 1
[версии недостатки] 1
[windows версии] 1
[главным однако] 1
[главным стремлением] 1
[microsoft стремлением] 1
[microsoft является] 1
[переманить является] 1
[на переманить] 1
[на неё] 1
[многочисленных неё] 1
[многочисленных пользователей] 1
[windows пользователей] 1
[на последняя] 1
[данный на] 1
[данный момент] 1
[момент уверенно] 1
[лидирует уверенно] 1
[и лидирует] 1
[и может] 1
[может считаться] 1
[самой считаться] 1
[популярной самой] 1
[из популярной] 1
[из когда] 1
[выпущенных либо] 1
[выпущенных операционных] 1
[операционных систем] 1
[для систем] 1
[для персональных] 1
[компьютеров персональных] 1
[показатели поэтому] 1
[показатели распространения] 1
[windows распространения] 1
[именно сравнивают] 1
[именно с] 1
[ней с] 1
[от статистика] 1
[netmarketshare от] 1
[netmarketshare показывает] 1
[в что] 1
[в первые] 1
[два первые] 1
[два месяца] 2
[месяца после] 1
[после релиза] 1
[дела релиза] 1
[windows дела] 1
[идут лучше] 1
[у чем] 1
[windows у] 3
[аналогичный за] 1
[аналогичный промежуток] 1
[времени промежуток] 1
[намного результат] 1
[намного ниже] 1
[как наглядно] 1
[наглядно показано] 1
[на показано] 1
[графике на] 1
[windows доля] 2
[два за] 1
[достигла месяца] 1
[достигла значения] 1
[в привлекла] 1
[в своё] 1
[время своё] 1
[внимание время] 1
[внимание только] 1
[windows однако] 1
[демонстрировала стабильные] 1
[результаты стабильные] 1
[в результаты] 1
[в течение] 1
[девяти течение] 1
[девяти месяцев] 1
[после чего] 1
[её чего] 1
[её темпы] 1
[распространения темпы] 1
[выросли распространения] 1
[выросли ещё] 1
[больше ещё] 1
[windows а] 1
[во второй] 1
[второй месяц] 1
[месяц устанавливали] 1
[примерно устанавливали] 1
[в примерно] 1
[в три] 1
[раза три] 1
[меньше раза] 1
[в чем] 1
[в первый] 1
[лет после] 1
[после появления] 1
[появления составляет] 1
[около составляет] 1
[а для] 1
[windows для] 1
[целью является] 1
[распространение является] 1
[на распространение] 1
[же пока] 1
[же результат] 1
[результат составляет] 1

[Invincible]

Iska, А как правильно запустить данный макрос?
Вставляю код в редактор Visual Basic, нажимаю Run (F5), но в документе где находится мой текст никаких изменений не происходит, пользуюсь Word 2013.

[Iska]

но в документе где находится мой текст никаких изменений не происходит »
А разве там должны происходить какие-либо изменения?

Находясь в редакторе VBA, попробуйте нажать «Ctrl-G» для отображения окна «Immediate», куда идёт вывод «Debug.Print».

При желании, конечно, можно сделать вывод в новый документ Word или в текстовый файл на диске.

[Invincible]

А разве там должны происходить какие-либо изменения?
Находясь в редакторе VBA, попробуйте нажать «Ctrl-G» для отображения окна «Immediate», куда идёт вывод «Debug.Print». »
Все получилось, просто я думал, что результат работы макроса заменит исходный текст.

А нельзя добавить, чтобы учитывались падежи слов? Чтобы слово из-за разного окончания слова относилось к одному слову, а не к 5 например.
И еще союзы, предлоги, частицы удалить из текста, такие как "и", "а".

[Iska]

А нельзя добавить, чтобы учитывались падежи слов? »
Я не припоминаю такого функционала в комплекте Microsoft Office.

И еще союзы, предлоги, частицы удалить из текста, такие как "и", "а". »
И такого тоже.

Если «союзы, предлоги, частицы удалить из текста» ещё возможно теоретически (если Вы перечислите все возможные варианты «союзы, предлоги, частицы»), то конкурировать с десятками и сотнями тысяч человеко-лет крупных контор в лексическом анализе нереально.

[Drongo]

И еще союзы, предлоги, частицы удалить из текста, такие как "и", "а". »Возможно подразумевалось не учитывать в подсчётах? Тогда исключить длину слова равную 1 символу в скрипте Iska. Однако это не выход и не решит задачи в целом. А насчёт падежей это по моему не получится, нужна как минимум база-словарь слов, да и то не факт что получится правильно распознать.

[Invincible]

Option Explicit

Sub Sample()
Dim objWord As Range

Dim strWord As String
Dim objDictionary As Object
Dim elem As Variant

Dim strWord1 As String
Dim strWord2 As String
Dim i As Integer


Set objDictionary = CreateObject("Scripting.Dictionary")

For Each objWord In ThisDocument.Words
strWord = RemoveNonAlpha(objWord.Text)

If Not Len(strWord) = 0 Then
If Not objDictionary.Exists(strWord) Then
objDictionary.Add strWord, 1
Else
objDictionary.Item(strWord) = objDictionary.Item(strWord) + 1
End If
End If
Next

For Each elem In objDictionary.Keys
Debug.Print "[" & elem & "]", objDictionary.Item(elem)
Next

objDictionary.RemoveAll


Debug.Print "===================================================================="


For i = 1 To ThisDocument.Words.Count - 1
strWord1 = LCase(RemoveNonAlpha(ThisDocument.Words.Item(i).Text))
strWord2 = LCase(RemoveNonAlpha(ThisDocument.Words.Item(i + 1).Text))

If Len(strWord1) > 0 And Len(strWord2) > 0 Then
If StrComp(strWord1, strWord2, vbTextCompare) = 1 Then
strWord = strWord2 & " " & strWord1
Else
strWord = strWord1 & " " & strWord2
End If

If Not objDictionary.Exists(strWord) Then
objDictionary.Add strWord, 1
Else
objDictionary.Item(strWord) = objDictionary.Item(strWord) + 1
End If
End If
Next

For Each elem In objDictionary.Keys
Debug.Print "[" & elem & "]", objDictionary.Item(elem)
Next

objDictionary.RemoveAll
Set objDictionary = Nothing
End Sub

Function RemoveNonAlpha(strValue As String) As String
With CreateObject("VBScript.RegExp")
.IgnoreCase = True
.Global = True
.Multiline = True
.Pattern = "([^a-zа-яё])*"

RemoveNonAlpha = .Replace(strValue, "")
End With
End Function
А что нужно изменить в этом макросе, чтобы учитывались три слова, стоящие рядом?