Sub DeleteCondensedStyles()
Dim Doc As Document, i As Long, Rng As Range, StlNmFnd As String, StlNmRep As String
Application.ScreenUpdating = False
Set Doc = ActiveDocument
With Doc
  For i = .Styles.Count To 1 Step -1
    With .Styles(i)
      If .BuiltIn = False Then
        If .Type = wdStyleTypeCharacter Then
          StlNmFnd = .NameLocal
          If InStr(StlNmFnd, "+") > 0 Then
            StlNmRep = Trim(Split(StlNmFnd, "+")(0))
            For Each Rng In Doc.StoryRanges
              With Rng.Find
                .ClearFormatting
                .Format = True
                .Style = StlNmFnd
                .Replacement.Style = StlNmRep
                .Execute Replace:=wdReplaceAll
              End With
            Next
            If .Linked = True Then
              Doc.Styles.Add Name:="TmpSty"
              .LinkStyle = "TmpSty"
              Doc.Styles("TmpSty").Delete
            Else
              .Delete
            End If
          End If
        End If
      End If
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub