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

myMainHighlight = wdBrightGreen

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

addLightColour = True
myLightColour = wdGray25

underlineLineFeeds = True
underlineQuoteNoPunct = False

myScreenOff = True

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

myOKChars = ".!?:…" & ChrW(8221) & ChrW(8217)
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
  Set rng = ActiveDocument.Content
  i = ActiveDocument.Paragraphs.count
  For Each myPar In ActiveDocument.Paragraphs
    If myPar.Range.Words.count > minWords + 2 Then
      rng.Start = myPar.Range.End - 2
      rng.End = myPar.Range.End - 1
      If rng = " " Then rng.Delete: rng.Start = rng.Start - 1
      If rng = " " Then rng.Delete: rng.Start = rng.Start - 1
      If rng.Text = ChrW(2) Then
         rng.Start = rng.Start - 1
         rng.End = rng.End - 1
      End If
      Do While rng.Font.Superscript <> 0
         rng.Start = rng.Start - 1
         rng.End = rng.End - 1
      Loop

      If InStr(myOKChars, rng) = 0 Then
        If rng = " " Then rng.Delete
        If rng.Font.Bold = False Then
          If rng.Information(wdWithInTable) = True Then
            rng.Font.Color = mySoftColour
          Else
            rng.HighlightColorIndex = myMainHighlight
          End If
        End If
      End If
    End If
    i = i - 1
    j = i / 10
    StatusBar = sps & j & "0"
    DoEvents
  Next myPar
  If ActiveDocument.Footnotes.count > 0 Then
    Set rng = ActiveDocument.StoryRanges(wdFootnotesStory)
    Set nts = ActiveDocument.StoryRanges(wdFootnotesStory)
    i = nts.Paragraphs.count
    For Each myPar In nts.Paragraphs
      rng.Start = myPar.Range.End - 2
      rng.End = myPar.Range.End - 1
      If rng = " " Then rng.Delete: rng.Start = rng.Start - 1
      If rng = " " Then rng.Delete: rng.Start = rng.Start - 1
      If InStr(myOKChars, rng) = 0 Then
        If rng = " " Then rng.Delete
        If rng.Font.Bold = False Then
          If rng.Information(wdWithInTable) = True Then
            rng.Font.Color = mySoftColour
          Else
            rng.HighlightColorIndex = myMainHighlight
          End If
        End If
      End If
      DoEvents
      i = i - 1
      j = i / 10
      StatusBar = sps & j & "0"
    Next myPar
  End If
  If ActiveDocument.Endnotes.count > 0 Then
    Set rng = ActiveDocument.StoryRanges(wdEndnotesStory)
    Set nts = ActiveDocument.StoryRanges(wdEndnotesStory)
    i = nts.Paragraphs.count
    For Each myPar In nts.Paragraphs
      rng.Start = myPar.Range.End - 2
      rng.End = myPar.Range.End - 1
      If rng = " " Then rng.Delete: rng.Start = rng.Start - 1
      If rng = " " Then rng.Delete: rng.Start = rng.Start - 1
      If InStr(myOKChars, rng) = 0 Then
        If rng = " " Then rng.Delete
        If rng.Font.Bold = False Then
          If rng.Information(wdWithInTable) = True Then
            rng.Font.Color = mySoftColour
          Else
            rng.HighlightColorIndex = myMainHighlight
          End If
        End If
      End If
      DoEvents
      i = i - 1
      j = i / 10
      StatusBar = sps & j & "0"
    Next myPar
  End If
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

If underlineQuoteNoPunct = True Then
  Options.DefaultHighlightColorIndex = myLightColour
  Set rng = ActiveDocument.Content
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^$"" "
    .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