Sub StyleCleaner()
Application.ScreenUpdating = False
Dim wdDocA As Document, wdDocB As Document, Stl As Style, StrStl As String, bHid As Boolean
bHid = ActiveWindow.View.ShowHiddenText
ActiveWindow.View.ShowHiddenText = True
Set wdDocA = ActiveDocument: StrStl = "|"
With wdDocA
  Set wdDocB = Documents.Open(FileName:=.AttachedTemplate.FullName, AddToRecentFiles:=False, Visible:=False)
  With wdDocB
    For Each Stl In .Styles
      If Stl.BuiltIn = False Then StrStl = StrStl & Stl.NameLocal & "|"
    Next
    .Close False
  End With
  For Each Stl In .Styles
    With Stl
      If .BuiltIn = False Then
        If .InUse = False Then
          If InStr(StrStl, "|" & .NameLocal & "|") = 0 Then
            .Delete
          Else
            Call DelUnusedStyle(wdDocA, .NameLocal)
          End If
        End If
      End If
    End With
  Next
End With
Set wdDocA = Nothing: Set wdDocB = Nothing
ActiveWindow.View.ShowHiddenText = bHid
Application.ScreenUpdating = True
MsgBox "All Done.", vbOKOnly
End Sub

Sub DelUnusedStyle(Doc As Document, StlNm As String)
Dim Rng As Range, Sctn As Section, HdFt As HeaderFooter, Shp As Shape, bDel As Boolean
bDel = True
With Doc
  'Loop through all story ranges
  For Each Rng In .StoryRanges
    bDel = Not bFnd(Rng, StlNm)
    If bDel = False Then Exit For
  Next
  'Loop through all headers & footers
  For Each Sctn In .Sections
    If bDel = False Then Exit For
    For Each HdFt In Sctn.Headers
      If bDel = False Then Exit For
      With HdFt
        If .Exists = True Then
          If (Sctn.Index = 1) Or (.LinkToPrevious = False) Then
            bDel = Not bFnd(HdFt.Range, StlNm)
            If bDel = False Then Exit For
            For Each Shp In .Shapes
              If bDel = False Then Exit For
              If Not Shp.TextFrame Is Nothing Then bDel = Not bFnd(Shp.TextFrame.TextRange, StlNm)
            Next
          End If
        End If
      End With
    Next
    For Each HdFt In Sctn.Footers
      If bDel = False Then Exit For
      With HdFt
        If .Exists = True Then
          If (Sctn.Index = 1) Or (.LinkToPrevious = False) Then
            bDel = Not bFnd(HdFt.Range, StlNm)
            If bDel = False Then Exit For
            For Each Shp In .Shapes
              If bDel = False Then Exit For
              If Not Shp.TextFrame Is Nothing Then bDel = Not bFnd(Shp.TextFrame.TextRange, StlNm)
            Next
          End If
        End If
      End With
    Next
  Next
  If bDel = True Then .Styles(StlNm).Delete
End With
End Sub

Function bFnd(Rng As Range, StlNm As String) As Boolean
With Rng.Find
  .ClearFormatting
  .Forward = True
  .Format = True
  .Style = StlNm
  .Wrap = wdFindContinue
  .Execute
  bFnd = .Found
End With
End Function