Sub PurgeStyles()

' Based on:
' http://wordtips.vitalnews.com/Pages/T0969_Removing_Unused_Styles.html
' by Allen Wyatt
' deletes unused styles in Word
' Revised - Original macro would only check out non-built-in styles
' Also gives summary of remaining styles

Application.ScreenUpdating = False

Const MaxStyles = 300

Dim oStyle As Style
Const MaxCount = 5
Dim mNames(1 To MaxStyles) As String
Dim mSizes(1 To MaxStyles) As Integer
Dim delStyles(1 To MaxStyles) As String
Dim delCount As Integer
Dim StyleCount As Integer, i As Integer

On Error Resume Next

StyleCount = 0
delCount = 0

Dim myCount As Integer
    
myCount = ActiveDocument.Styles.Count

If myCount > MaxStyles Then Stop
    
For i = myCount To 1 Step -1
    Selection.HomeKey Unit:=wdStory
    Set oStyle = ActiveDocument.Styles(i)
  
    ' Original macro would only check out non-built-in styles
    ' If oStyle.BuiltIn = False Then
    
    With Selection.Find
        .ClearFormatting
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Style = oStyle.NameLocal
        .Execute
        If .Found = False Then
            delCount = delCount + 1
            delStyles(delCount) = .Style
            oStyle.Delete
        Else
            StyleCount = StyleCount + 1
            mSizes(StyleCount) = 1
            mNames(StyleCount) = .Style
            While .Found And mSizes(StyleCount) < MaxCount
                mSizes(StyleCount) = mSizes(StyleCount) + 1
                Selection.MoveRight Unit:=wdCharacter, Count:=1
                .Execute
            Wend
        End If
    End With
      
    '  End If
    
Next


    Documents.Add DocumentType:=wdNewBlankDocument
    Selection.WholeStory
    Selection.ParagraphFormat.TabStops.ClearAll
    ActiveDocument.DefaultTabStop = InchesToPoints(0.5)
    Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(3), _
    Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
    
    With Selection.ParagraphFormat
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineUnitBefore = 0
        .LineUnitAfter = 0
    End With
    Selection.HomeKey Unit:=wdStory

    For i = StyleCount To 1 Step -1
        Selection.TypeText Text:=delStyles(i)
        Selection.TypeParagraph
    Next
    Selection.TypeParagraph

    For i = StyleCount To 1 Step -1
        Selection.TypeText Text:=mNames(i)
        Selection.TypeText Text:=vbTab
        Selection.TypeText Text:=mSizes(i)
        Selection.TypeParagraph
    Next

Application.ScreenUpdating = True
Application.ScreenRefresh

End Sub