Sub CaptionsListAll()
' Paul Beverley - Version 25.05.23
' Lists all paragraphs with bold Figure, Table, Box

captionsAreBold = True
maxWords = 40

Set rng = ActiveDocument.Content
Documents.Add
Selection.FormattedText = rng.FormattedText

Set rng = ActiveDocument.Content
rng.HighlightColorIndex = wdYellow
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "^13[FTB][iao][gbx][ul .]"
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = True
  .Execute
End With

myCount = 0
Do While rng.Find.Found = True
  rng.MoveStart , 1
  rng.Expand wdParagraph
  grabThisOne = True
  If captionsAreBold = True And rng.Font.Bold _
       = False Then grabThisOne = False
  If rng.Words.count > maxWords Then grabThisOne = False
  If grabThisOne = True Then rng.HighlightColorIndex = wdNoHighlight
  rng.Collapse wdCollapseEnd
  rng.Find.Execute
  DoEvents
Loop

Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .Highlight = True
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With
For i = rng.Tables.count To 1 Step -1
  rng.Tables(i).Delete
Next i
Beep
End Sub