Question

我在这里找到了什么样的答案：

Highlight (not delete) repeat sentences or phrases in a word document

但在阅读完所有代码和答案后，我真的不知道如何处理代码或如何运行代码！这是一个自定义宏我可以复制/粘贴吗？我喜欢这种即插即用的解决方案。像原作者一样，我将文档从其他几个文档中剪切并粘贴在一起，我确定有重复的句子等等 - 我只想轻松找到它们，这样我就可以删除或重新编写它们。谢谢！

Answer 1

You write macros in a part of Word that most users never see: the Visual Basic Editor (the VBE). Open the VBE by using any one of the following methods:

Press the keyboard shortcut, Alt+F11

Click the Visual Basic button on the Developer tab. To do that, click the File tab, and then click Options. On the Word Options dialog box, click Customize Ribbon. In the right side of the dialog box, select the Developer tab. Click OK to return to your document, and then on the Developer tab, click the Visual Basic button.

Add the Visual Basic command to the Quick Access Toolbar.

From https://msdn.microsoft.com/en-us/library/office/ff604039(v=office.14).aspx

In my experience with that thread, the top code seems to work mostly.

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

I added the code to the ThisDocument item in the left sidebar, and then was able to run it. (I got an error about a string being too long, but it seems it still partly worked because there are now purple highlights in the document.)

n.b., it probably only works on the Windows version of Word. I had it work in Word 2016 Preview.

突出显示Word文档中的重复句子或短语

1 个答案: