View Single Post
 
Old 06-29-2025, 05:07 AM
gmaxey gmaxey is offline Windows 10 Office 2019
Expert
 
Join Date: May 2010
Location: Brasstown, NC
Posts: 1,617
gmaxey is just really nicegmaxey is just really nicegmaxey is just really nicegmaxey is just really nicegmaxey is just really nice
Default

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
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote