突出显示(而不是删除)重复的句子或短语

问题描述

我的印象是这在 word 中是不可能的，但我想如果您在很长的论文中的任何地方寻找任何 3-4 个以相同顺序出现的单词，我都可以找到相同短语的重复项.

I am getting the impression that this is not possible in word but I figure if you are looking for any 3-4 words that come in the same sequence anywhere in a very long paper I could find duplicates of the same phrases.

我从过去的论文中复制并粘贴了很多文档，并希望找到一种简单的方法来在这个 40 多页的文档中找到任何重复的信息，有很多不同的格式，但我愿意暂时摆脱格式化以便查找重复信息.

I copy and pasted a lot of documentation from past papers and was hoping to find a simple way to find any repeated information in this 40+ page document there is a lot of different formatting but I would be willing to temporarily get rid of formatting in order to find repeated information.

推荐答案

要突出显示所有重复的句子，您还可以使用 ActiveDocument.Sentences(i).这是一个例子

To highlight all duplicate sentences, you can also use ActiveDocument.Sentences(i). Here is an example

逻辑

1) 将word文档中的所有句子放入一个数组中

1) Get all the sentences from the word document in an array

2) 对数组进行排序

3) 提取重复项

4) 突出显示重复项

代码

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

快照

之前

之后

这篇关于突出显示(而不是删除)重复的句子或短语的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！