Sub ContentsListerByStyle()
' Paul Beverley - Version 23.06.23
' Create a contents list from numbered heading style

bigFontSize = 12

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

For Each myTable In ActiveDocument.Tables
  myTable.Delete
Next myTable

For Each myPara In ActiveDocument.Paragraphs
  cutIt = True
  mySize = myPara.Range.Font.Size
  If mySize > bigFontSize And mySize < 100 Then cutIt = False
  myStyle = Left(myPara.Range.Style, 4)
  myText = myPara.Range.Text
  If Left(myPara.Range.Style, 4) = "Head" Then cutIt = False
  ' If myPara.Range.Style = "Heading 2" Then cutIt = True
  ' If myPara.Range.Style = "Heading 3" Then cutIt = True

  If cutIt = True Then myPara.Range.Font.Color = wdColorBlue
  DoEvents
Next myPara
Beep
Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .Font.Color = wdColorBlue
  .Wrap = wdFindContinue
  .Forward = True
  .Replacement.Text = ""
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  DoEvents
End With
Beep
End Sub