Sub RepeatedWordsInParagraphs()
' Paul Beverley - Version 10.09.23
' Highlights any words duplicated within given paragraphs

wdsIgnore = ",about,been,from,have,here,some,into,"
wdsIgnore = wdsIgnore & ",that,their,them,then,there,these,they,"
wdsIgnore = wdsIgnore & ",this,those,very,were,will,what,with,"
wdsIgnore = wdsIgnore & ",it" & ChrW(8217) & "s," ' This is for "it's"

useHighlight = True
useColour = False
useManyColours = True

Dim myCol(20)
myCol(1) = wdYellow
myCol(2) = wdBrightGreen
myCol(3) = wdTurquoise
myCol(4) = wdPink
myCol(5) = wdRed
myCol(6) = wdGray25
myCol(7) = wdGray50
myCol(8) = wdDarkYellow

myCol(11) = wdColorPink
myCol(12) = wdColorBlue
myCol(13) = wdColorRed
myCol(14) = wdColorBrightGreen
myCol(15) = wdColorPink
myCol(16) = wdColorBlue
myCol(17) = wdColorRed
myCol(18) = wdColorBrightGreen
myColTotal = 8

myCount = 0
col = 1
parNum = ActiveDocument.Range(0, Selection.Paragraphs(1).Range.End).Paragraphs.Count
For par = parNum To ActiveDocument.Paragraphs.Count
  Set pa = ActiveDocument.Paragraphs(par)
  txt = LCase(pa.Range.Text)
  lenpar = Len(txt)
  wds = ","
  For i = 1 To pa.Range.Words.Count
    wd = LCase(Trim(pa.Range.Words(i)))
    lnw = Len(wd)
    If lnw > 3 And InStr(wdsIgnore, "," & wd & ",") = 0 Then
      Set rng = pa.Range.Duplicate
      rs = rng.Start
      newtxt = Replace(txt, wd, "")
      If (lenpar - Len(newtxt)) > lnw And _
           InStr(wds, "," & wd & ",") = 0 Then
        wds = wds & wd & ","
        For j = 1 To lenpar - lnw
          If Mid(txt, j, lnw) = wd Then
            rng.Start = rs + j - 1
            rng.End = rng.Start + lnw
            If useHighlight Then
              rng.HighlightColorIndex = myCol(col)
            End If
            If useColour Then
              rng.Font.Color = myCol(col + 10)
            End If
            j = j + lnw
          End If
        Next j
        If useManyColours Then col = col Mod myColTotal + 1
        DoEvents
      End If
    End If
    DoEvents
  Next i
  myCount = myCount + 1
  If myCount = 20 Then
    pa.Range.Words(1).Select
    myCount = 0
  End If
Next par
End Sub