Вопрос по ms-word, vba, word-vba – Выделите (не удаляйте) повторяющиеся предложения или фразы в текстовом документе

9

У меня складывается впечатление, что это невозможно в слове, но я полагаю, что если вы ищете какие-либо 3-4 слова, которые встречаются в одной и той же последовательности в любом месте очень длинной статьи, я могу найти дубликаты тех же фраз.

Я скопировал и вставил много документации из прошлых работ и надеялся найти простой способ найти любую повторяющуюся информацию в этом 40-страничном документе. Существует много разных форматов, но я бы хотел временно избавиться от форматирования, чтобы найти повторную информацию.

Это было бы сложно. В первом абзаце вашего вопроса есть 81 группа из 3 и 4 слов. Представьте, сколько их будет в 40-страничном документе. Gilbert Le Blanc
Будет ли концепция похожа наDAWG Помогите? Я думаю, что поиск каждой группы слов последовательно, начиная с первого слова в документе (добавление в DAWG / ссылка на то, что уже было добавлено по ходу, где каждый узел - это слово, а не буква), было бы невозможно. Вам просто нужно найти способ создать эту структуру в VBA и / или использовать внешнюю DLL. Однажды я попробовал нечто подобное, но нашел, что это довольно сложно, используя стандартные доступные библиотеки. Gaffi
Интересно, могли бы вы взглянуть на конкретные слова - слова длиннее, скажем, на семь букв? Тогда можно будет взглянуть на слова с любой стороны или на такие ключевые слова. Fionnuala

Ваш Ответ

3   ответа
4

Я не использовал свое собственное предложение DAWG, и мне все еще интересно узнать, есть ли у кого-то еще способ сделать это, но я смог придумать это:

Option Explicit

Sub test()
Dim ABC As Scripting.Dictionary
Dim v As Range
Dim n As Integer
    n = 5
    Set ABC = FindRepeatingWordChains(n, ActiveDocument)
    ' This is a dictionary of word ranges (not the same as an Excel range) that contains the listing of each word chain/phrase of length n (5 from the above example).
    ' Loop through this collection to make your selections/highlights/whatever you want to do.
    If Not ABC Is Nothing Then
        For Each v In ABC
            v.Font.Color = wdColorRed
        Next v
    End If
End Sub

' This is where the real code begins.
Function FindRepeatingWordChains(ChainLenth As Integer, DocToCheck As Document) As Scripting.Dictionary
Dim DictWords As New Scripting.Dictionary, DictMatches As New Scripting.Dictionary
Dim sChain As String
Dim CurWord As Range
Dim MatchCount As Integer
Dim i As Integer

    MatchCount = 0

    For Each CurWord In DocToCheck.Words
        ' Make sure there are enough remaining words in our document to handle a chain of the length specified.
        If Not CurWord.Next(wdWord, ChainLenth - 1) Is Nothing Then
            ' Check for non-printing characters in the first/last word of the chain.
            ' This code will read a vbCr, etc. as a word, which is probably not desired.
            ' However, this check does not exclude these 'words' inside the chain, but it can be modified.
            If CurWord <> vbCr And CurWord <> vbNewLine And CurWord <> vbCrLf And CurWord <> vbLf And CurWord <> vbTab And _
                CurWord.Next(wdWord, ChainLenth - 1) <> vbCr And CurWord.Next(wdWord, ChainLenth - 1) <> vbNewLine And _
                CurWord.Next(wdWord, ChainLenth - 1) <> vbCrLf And CurWord.Next(wdWord, ChainLenth - 1) <> vbLf And _
                CurWord.Next(wdWord, ChainLenth - 1) <> vbTab Then
                sChain = CurWord
                For i = 1 To ChainLenth - 1
                    ' Add each word from the current word through the next ChainLength # of words to a temporary string.
                    sChain = sChain & " " & CurWord.Next(wdWord, i)
                Next i

                ' If we already have our temporary string stored in the dictionary, then we have a match, assign the word range to the returned dictionary.
                ' If not, then add it to the dictionary and increment our index.
                If DictWords.Exists(sChain) Then
                    MatchCount = MatchCount + 1
                    DictMatches.Add DocToCheck.Range(CurWord.Start, CurWord.Next(wdWord, ChainLenth - 1).End), MatchCount
                Else
                    DictWords.Add sChain, sChain
                End If
            End If
        End If
    Next CurWord

    ' If we found any matching results, then return that list, otherwise return nothing (to be caught by the calling function).
    If DictMatches.Count > 0 Then
        Set FindRepeatingWordChains = DictMatches
    Else
        Set FindRepeatingWordChains = Nothing
    End If

End Function

Я проверил это на 258 страницах документа (TheStory.txt) отэтот источники он побежал всего за несколько минут.

Увидетьtest() саб для использования.

Вам нужно будет сослаться на Microsoft Scripting Runtime, чтобы использоватьScripting.Dictionary объекты. Если это нежелательно, небольшие изменения могут быть сделаны для использованияCollections вместо этого, но я предпочитаюDictionary как это полезно.Exists() метод.

@SiddharthRout Я не собирался тратить время впустую; Я действительно хотел увидеть несколько разных способов сделать это. Я не проверял свою скорость до сих пор. В любом случае я планировал вручить вам награду! ;-)
Образец файла для тестирования. Это 41,8 кб - 800 страниц (119996 слов). В файле также есть мой и ваши макросы, которые я использовал.wikisend.com/download/356770/Sample.docm
Мне любопытно, если ваш код занимал меньше минуты для документа размером 625 МБ, тогда зачем предлагать награду и тратить наше время :) Или вы ожидаете код, который достигает этого за 15-20 секунд ??
Я не делал этого за вознаграждение :) Вы можете наградить его Ким или себе. Это нормально со мной. Я просто искал сложный вопрос;)I did not test the speed of my own until just now. Если это факт, я забираю свои слова обратно. Мне было просто любопытно, что если ваш код делает то, что вы говорите (что я до сих пор считаю невероятным), тогда вам действительно не нужен какой-либо другой код;) Но если серьезно, ваш код умудряется найти все повторяющиеся предложения И фразы в документе на 258 страниц меньше чем минуту? К сожалению, я не могу проверить это, поскольку я не могу загрузить этот тяжелый документ объемом 625 МБ.
@SiddharthRout Если кто-то еще хочет повторить тестирование, я очень открыт для этого! Я дважды пробежал по той же причине, но закончил с похожими результатами. Я не буду исключать ошибки, заканчивающиеся преждевременно, но я не использовал никакихOn Error шаги, поэтому я бы ожидал предупреждение / диалог. Я также отсканировал документ и нашел основные моменты повсюду, вплоть до последней страницы. Если кто-то докажет, что я не прав, тогда я хотел бы узнать, что я сделал не так с моим тестом (запустите фразы из 5 слов, что, вероятно, имеет значение), поэтому я не буду делать это снова!
2

Я выбрал довольно неубедительную теорию, но, похоже, она работает (по крайней мере, если я правильно понял вопрос, потому что иногда я медлительный понимающий). Я загружаю весь текст в строку, загружаю отдельные слова в массив, перебираю массив и объединяю строку, содержащую каждый раз три слова подряд.
Поскольку результаты уже включены в группы из 3 слов, автоматически распознаются группы из 4 или более слов.

Option Explicit

Sub Find_Duplicates()

On Error GoTo errHandler

Dim pSingleLine                     As Paragraph
Dim sLine                           As String
Dim sFull_Text                      As String
Dim vArray_Full_Text                As Variant

Dim sSearch_3                       As String
Dim lSize_Array                     As Long
Dim lCnt                            As Long
Dim lCnt_Occurence                  As Long


'Create a string from the entire text
For Each pSingleLine In ActiveDocument.Paragraphs
    sLine = pSingleLine.Range.Text
    sFull_Text = sFull_Text & sLine
Next pSingleLine

'Load the text into an array
vArray_Full_Text = sFull_Text
vArray_Full_Text = Split(sFull_Text, " ")
lSize_Array = UBound(vArray_Full_Text)


For lCnt = 1 To lSize_Array - 1
    lCnt_Occurence = 0
    sSearch_3 = Trim(fRemove_Punctuation(vArray_Full_Text(lCnt - 1) & _
                    " " & vArray_Full_Text(lCnt) & _
                    " " & vArray_Full_Text(lCnt + 1)))

    With Selection.Find
        .Text = sSearch_3
        .Forward = True
        .Replacement.Text = ""
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False

        Do While .Execute

            lCnt_Occurence = lCnt_Occurence + 1
            If lCnt_Occurence > 1 Then
                Selection.Range.Font.Color = vbRed
            End If
            Selection.MoveRight
        Loop
    End With

    Application.StatusBar = lCnt & "/" & lSize_Array
Next lCnt

errHandler:
Stop

End Sub

Public Function fRemove_Punctuation(sString As String) As String

Dim vArray(0 To 8)      As String
Dim lCnt                As Long


vArray(0) = "."
vArray(1) = ","
vArray(2) = ","
vArray(3) = "?"
vArray(4) = "!"
vArray(5) = ";"
vArray(6) = ":"
vArray(7) = "("
vArray(8) = ")"

For lCnt = 0 To UBound(vArray)
    If Left(sString, 1) = vArray(lCnt) Then
        sString = Right(sString, Len(sString) - 1)
    ElseIf Right(sString, 1) = vArray(lCnt) Then
        sString = Left(sString, Len(sString) - 1)
    End If
Next lCnt

fRemove_Punctuation = sString

End Function

Код предполагает непрерывный текст без маркеров.

Я не завершил тест (потому что это заняло так много времени), но это заняло значительно больше времени, чем мой или Сид для очень большого файла (см. Примечание к моему ответу). Тем не менее, он все еще работает хорошо для небольших файлов.
Это очень возможно. Обдумывая это, я также, вероятно, должен был использовать словари; загрузка массива строк из 3 слов в словарь, если он существует - & gt; скопировать в новый словарь и ограничить мой & quot; поиск - & gt; Цвет & Quot; только те строки, которые применимы. Я полагаю, что "существует" Метод из словарей может существенно повысить производительность (с помощью ключей) и, возможно, повторяющийся и явный "поиск" это то, что делает его медленным
Пока я читал это (не проверял себя), так как вы разделяете на" "Не совпадают ли слова, которые заканчивают предложение (или которые разделены запятой / другой пунктуацией)? Пример:"I like to do this." против"I like to do this sometimes." (также я "+1" за хороший ответ, но у меня нет голосов за день ...)
Не беспокойтесь о голосовании, и вы правы. У меня больше нет доступа к моему ПК с тех пор, как я ушел с работы, но завтра я напишу небольшую функцию для удаления знаков препинания из строки поиска.
Функция была добавлена.
16

Чтобы выделить все повторяющиеся предложения, вы также можете использоватьActiveDocument.Sentences(i), Вот пример

LOGIC

1) Получить все предложения из документа word в массиве

2) Сортировать массив

3) Извлечь дубликаты

4) Выделить дубликаты

CODE

Option Explicit

Sub Sample()
    Dim MyArray() As String
    Dim n As Long, i As Long
    Dim Col As New Collection
    Dim itm

    n = 0
    '~~> Get all the sentences from the word document in an array
    For i = 1 To ActiveDocument.Sentences.Count
        n = n + 1
        ReDim Preserve MyArray(n)
        MyArray(n) = Trim(ActiveDocument.Sentences(i).Text)
    Next

    '~~> Sort the array
    SortArray MyArray, 0, UBound(MyArray)

    '~~> Extract Duplicates
    For i = 1 To UBound(MyArray)
        If i = UBound(MyArray) Then Exit For
        If InStr(1, MyArray(i + 1), MyArray(i), vbTextCompare) Then
            On Error Resume Next
            Col.Add MyArray(i), """" & MyArray(i) & """"
            On Error GoTo 0
        End If
    Next i

    '~~> Highlight duplicates
    For Each itm In Col
        Selection.Find.ClearFormatting
        Selection.HomeKey wdStory, wdMove
        Selection.Find.Execute itm
        Do Until Selection.Find.Found = False
            Selection.Range.HighlightColorIndex = wdPink
            Selection.Find.Execute
        Loop
    Next
End Sub

'~~> Sort the array
Public Sub SortArray(vArray As Variant, i As Long, j As Long)
  Dim tmp As Variant, tmpSwap As Variant
  Dim ii As Long, jj As Long

  ii = i: jj = j: tmp = vArray((i + j) \ 2)

  While (ii <= jj)
     While (vArray(ii) < tmp And ii < j)
        ii = ii + 1
     Wend
     While (tmp < vArray(jj) And jj > i)
        jj = jj - 1
     Wend
     If (ii <= jj) Then
        tmpSwap = vArray(ii)
        vArray(ii) = vArray(jj): vArray(jj) = tmpSwap
        ii = ii + 1: jj = jj - 1
     End If
  Wend
  If (i < jj) Then SortArray vArray, i, jj
  If (ii < j) Then SortArray vArray, ii, j
End Sub

SNAPSHOTS

BEFORE

enter image description here

AFTER

enter image description here

Хорошо. Я добавлю эту часть, а также :)
Хороший ответ, но я понимаю, что ОП ищет фразы, которые могут не занимать целое предложение.
В этом случае OP должен будет определить минимальное количество слов в фразе, иначе это создаст путаницу.This is a green apple а такжеThis is a green Ball. This is a green быть обычным в них :)
ОПdid (...looking for any 3-4 words that come in the same sequence...) в оригинальном вопросе. Мой пример позволяет настроить то же самое (с переданным аргументомChainLength).

Похожие вопросы