Sub ListAllStyles()
' Paul Beverley - Version 22.04.24
' Creates a list of all styles name

myStyles = ""
myStyles = "Normal,Default,"

displayParaWords = True
numWords = 6
deleteTableBorders = False

Set myFile = ActiveDocument
myAllText = ""

For myArea = 1 To 3
  doThisArea = False
  ' Main text area
  If myArea = 1 Then
    If Selection.Start = Selection.End Then
      myResponse = MsgBox("Scan the whole document?!", _
           vbQuestion + vbYesNo, "StyleLister")
      If myResponse <> vbYes Then Exit Sub
      Set rng = ActiveDocument.Content
    Else
      Set rng = Selection.Range.Duplicate
    End If
    doThisArea = True
  End If
  ' Footnotes, if any
  If ActiveDocument.Footnotes.Count > 0 And myArea = 2 Then
    doThisArea = True
    Set rng = ActiveDocument.StoryRanges(wdFootnotesStory)
    StatusBar = "Scanning footnotes"
  End If
  ' Endnotes, if any
  If ActiveDocument.Endnotes.Count > 0 And myArea = 3 Then
    doThisArea = True
    Set rng = ActiveDocument.StoryRanges(wdEndnotesStory)
    StatusBar = "Scanning endnotes"
  End If
  If doThisArea = True Then
    For Each myPar In rng.Paragraphs
      Set myPar = myPar.Range
      myPar.Select
      If myPar.Hyperlinks.Count = 0 Then
        thisStyle = myPar.Style
        If InStr(myStyles, thisStyle) = 0 Then
          myStyles = myStyles & thisStyle & ","
          Set testChar = myPar.Characters(1)
          pageNum = testChar.Information(wdActiveEndAdjustedPageNumber)
          myLineText = thisStyle & vbTab & "p." & Trim(Str(pageNum))
          If displayParaWords Then
            myStart = testChar.Start
            If myPar.Words.Count > numWords Then
              myEnd = myPar.Words(numWords).End
            Else
              myEnd = myPar.End - 1
            End If
            myLen = myEnd - myStart
            myWords = Left(myPar.Text, myLen)
            ' Get rid of footnote markers
            myWords = Replace(myWords, Chr(2), "")
            myLineText = myLineText & vbTab & Trim(myWords)
            Debug.Print myLineText
            myAllText = myAllText & myLineText & vbCr
          End If
        End If
        DoEvents
      End If
    Next myPar
  End If
Next myArea

' Display the results in a table
Documents.Add
Selection.TypeText Text:=myAllText
Set rng = ActiveDocument.Content
rng.Sort
Selection.HomeKey Unit:=wdStory
Selection.TypeText "Style list"
startTable = Selection.End + 1
ActiveDocument.Paragraphs(1).Style = _
     ActiveDocument.Styles(wdStyleHeading1)
rng.Start = startTable
rng.End = ActiveDocument.Range.End
rng.ConvertToTable Separator:=wdSeparateByTabs
Set tb = ActiveDocument.Tables(1)
tb.AutoFitBehavior (wdAutoFitContent)
If deleteTableBorders = True Then
  tb.Borders(wdBorderTop).LineStyle = wdLineStyleNone
  tb.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
  tb.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
  tb.Borders(wdBorderRight).LineStyle = wdLineStyleNone
  tb.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
  tb.Borders(wdBorderVertical).LineStyle = wdLineStyleNone
End If
End Sub