This is an adaptations of Paul's code that he provided in his linked answer. You can change the value I have "6" words to whatever number you like.
Code:
Sub FindDuplicateStrings()
Application.ScreenUpdating = False
Dim i As Long, RngSrc As Range, RngFnd As Range
Dim oRng As Range
Const Clr As Long = wdBrightGreen
Dim eTime As Single
eTime = Timer
Options.DefaultHighlightColorIndex = Clr
Dim oCol As New Collection
With ActiveDocument
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Set RngSrc = .Range
RngSrc.End = .Words(6).End 'Change "6" to a number to suit.
MsgBox RngSrc.Text
Do
i = i + 1
If i Mod 100 = 0 Then DoEvents
On Error Resume Next
'If RngSrc.HighlightColorIndex <> Clr Then
Set RngFnd = .Range(RngSrc.End, .Range.End)
If Len(RngSrc.Text) < 256 Then
With RngFnd.Find
.Text = RngSrc.Text
.Replacement.Text = "^&"
.Replacement.Highlight = True
.Wrap = wdFindStop
.Execute Replace:=wdReplaceAll
End With
Else
With RngFnd
With .Find
.Text = Left(RngSrc.Text, 255)
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found
If RngSrc.Text = .Duplicate.Text Then
RngSrc.HighlightColorIndex = Clr
.Duplicate.HighlightColorIndex = Clr
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End If
'End If
RngSrc.MoveStart wdWord, 1
RngSrc.MoveEnd wdWord, 1
Loop Until RngSrc.End = .Range.End
End With
' Report time taken. Elapsed time calculation allows for execution to extend past midnight.
MsgBox "Finished. Elapsed time: " & (Timer - eTime + 86400) Mod 86400 & " seconds."
Application.ScreenUpdating = True
End Sub