Try:
Code:
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