Sub DeleteUnusedStyles()
Dim Doc As Document, Rng As Range, Shp As Shape
Dim StlNm As String, i As Long, bDel As Boolean
Application.ScreenUpdating = False
On Error Resume Next
Set Doc = ActiveDocument
With Doc
  For i = .Styles.Count To 1 Step -1
    With .Styles(i)
      If .BuiltIn = False And .Linked = False Then
        bDel = True: StlNm = .NameLocal
        For Each Rng In Doc.StoryRanges
          With Rng.Find
            .ClearFormatting
            .Format = True
            .Style = StlNm
            .Execute
            If .Found = True Then
              bDel = False
              Exit For
            End If
          End With
          For Each Shp In Rng.ShapeRange
            If Not Shp.TextFrame Is Nothing Then
              With Shp.TextFrame.TextRange.Find
                .ClearFormatting
                .Format = True
                .Style = StlNm
                .Execute
                If .Found = True Then
                  bDel = False
                  Exit For
                End If
              End With
            End If
          Next
        Next
        If bDel = True Then .Delete
      End If
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub