Sub ParagraphEndChecker()
' Paul Beverley - Version 22.12.23
' Highlights the end of all possibly punctuation-less paragraphs

myMainHighlight = wdBrightGreen

mySoftColour = wdColorBlue
' or for no coloration inside tables
' mySoftColour = wdColorAutomatic

myOKChars = ".!?:…"

addLightColour = True
' addLightColour = False
myLightColour = wdGray25

' To not highlight all headings,
'  ignore short "paragraphs" = headings.
minWords = 10


underlineLineFeeds = True

myScreenOff = True

Dim i As Long
Dim j As Long

If myScreenOff = True Then
  Application.ScreenUpdating = False
  On Error GoTo ReportIt
End If

If addLightColour = True Then
  oldColour = Options.DefaultHighlightColorIndex
  Options.DefaultHighlightColorIndex = myLightColour
  Set rng = ActiveDocument.Content
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ".^p"
    .Wrap = wdFindContinue
    .Replacement.Highlight = True
    .Replacement.Text = ""
    .Forward = True
    .MatchCase = False
    .MatchWildcards = False
    .MatchWholeWord = False
    .MatchSoundsLike = False
    .Execute Replace:=wdReplaceAll
  End With
  If ActiveDocument.Endnotes.Count > 0 Then
    Set rng = ActiveDocument.StoryRanges(wdEndnotesStory)
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ".^p"
      .Wrap = wdFindContinue
      .Replacement.Highlight = True
      .Replacement.Text = ""
      .Forward = True
      .MatchCase = False
      .MatchWildcards = False
      .MatchWholeWord = False
      .MatchSoundsLike = False
      .Execute Replace:=wdReplaceAll
    End With
  End If
  If ActiveDocument.Footnotes.Count > 0 Then
    Set rng = ActiveDocument.StoryRanges(wdFootnotesStory)
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ".^p"
      .Wrap = wdFindContinue
      .Replacement.Highlight = True
      .Replacement.Text = ""
      .Forward = True
      .MatchCase = False
      .MatchWildcards = False
      .MatchWholeWord = False
      .MatchSoundsLike = False
      .Execute Replace:=wdReplaceAll
    End With
  End If
  Options.DefaultHighlightColorIndex = oldColour
End If

sps = "": For i = 1 To 20: sps = sps & "        ": Next i
myTrack = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False
If Selection.Start <> Selection.End Then
    myResponse = MsgBox("Remove existing highlights?", vbQuestion _
          + vbYesNoCancel, "ParagraphEndChecker")
  If myResponse <> vbYes Then
    Application.ScreenUpdating = True
    Exit Sub
  End If
  Set rng = ActiveDocument.Content
  For Each myPar In ActiveDocument.Paragraphs
    rng.Start = myPar.Range.End - 3
    rng.End = myPar.Range.End - 1
    rng.Font.Color = wdColorAutomatic
    rng.HighlightColorIndex = wdNoHighlight
    DoEvents
  Next myPar
Else
  For myPass = 1 To 3
    If myPass = 1 And ActiveDocument.Endnotes.Count = 0 Then _
      myPass = 2
    If myPass = 2 And ActiveDocument.Footnotes.Count = 0 Then _
      myPass = 3
    Select Case myPass
      Case 1: Set rng = ActiveDocument.StoryRanges(wdEndnotesStory)
      Case 2: Set rng = ActiveDocument.StoryRanges(wdFootnotesStory)
      Case 3: Set rng = ActiveDocument.Content
    End Select
    i = rng.Paragraphs.Count
    For Each myPar In rng.Paragraphs
      Set testRng = myPar.Range
      testRng.End = testRng.End - 1
      If testRng.Font.Bold = False Then
        If Right(testRng.Text, 1) = " " Then _
             testRng.End = testRng.End - 1
        If Right(testRng.Text, 1) = " " Then _
             testRng.End = testRng.End - 1
        If testRng.Words.Count > minWords + 2 Then
          myLen = Len(testRng)
          myTest = Right(testRng.Text, 3)
          gottaPunc = False
          For x = 3 To 1 Step -1
            If InStr(myOKChars, Mid(myTest, x, 1)) > 0 Then
              gottaPunc = True
              puncPosn = x
              Exit For
            End If
            DoEvents
          Next x
          testRng.Start = testRng.End - 2
          If gottaPunc = False Then
            If testRng.Information(wdWithInTable) = True Then
              testRng.Font.Color = mySoftColour
            Else
              testRng.HighlightColorIndex = myMainHighlight
            End If
          Else
            If addLightColour = True And gottaPunc = True Then
              Set rng2 = rng.Duplicate
              rng2.Start = rng2.End - 1
              rng2.HighlightColorIndex = myLightColour
            End If
          End If
        End If
        i = i - 1
        If i Mod 10 = 0 Then StatusBar = sps & i
        DoEvents
      End If
    Next myPar
  Next myPass
End If

If underlineLineFeeds = True Then
  Options.DefaultHighlightColorIndex = myLightColour
  Set rng = ActiveDocument.Content
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^?^?^11^?^?"
    .Wrap = wdFindContinue
    .Replacement.Font.Underline = True
    .Replacement.Highlight = True
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll
  End With
  Options.DefaultHighlightColorIndex = oldColour
End If

ActiveDocument.TrackRevisions = myTrack
Beep
Application.ScreenUpdating = True
Exit Sub

ReportIt:
Application.ScreenUpdating = True
On Error GoTo 0
Resume
End Sub