Removing Unused Styles

tanx a lot Master! it works.

Thanks for a great explanation!
However, I am having problems with this deleting also styles I only use in footnotes, as well as character styles in use. Do you know if there is a workaround for this?

The 5941 error occurs because Styname is not the name of a valid style which is curious because the code is stepping through all the styles.

A fix is to add the following line before the line that raises the error:
On Error Resume Next

Hello,
I have Run Time Error 5941 at string:

If Not ActiveDocument.Styles(Styname).InUse Then

Hello,
I have Run Time Error 5941 at string:

If Not ActiveDocument.Styles(Styname).InUse Then

Peter Bates,
Did you find any solution?

This tip doesn't appear to work in Microsoft Word 2020

Amanda,
I haven’t used the recursive version for several years so I would have to dig it out of my archives. I don’t use it anymore because the single pass version given in my posting of the 23May20 is adequate. It is rare to need more than two passes to delete all unused styles. A more user friendly version is incorporated into the styles module of my Word tools, Google editorkae to find them.

Ken, I would be interested in seeing the recursive version of your macro. I have documents with hundreds of unused styles from MagicDraw. I've tried everything and searched Google time and time again with no luck!

Okay, it works, i needed to added in the macro main popup window.

I tried this code on mac word 2016 v15.22. it crashes immediatly. Im not sure ive added in the correct spot.
I added it as a module, is that the propper way of adding this code?

Run in Word 2016 but got run-time erro 5834. Searched about this but no clue how to fix it.

Thanks so much for the clarification

Zvi,

What you are seeing occurs because you have a custom style that is based on other custom style and so on resulting in a tree structure of dependencies. If one of the dependent styles is be used in the document but the base style is not specifically used then the base style should not be deleted. Therefore the deleting of unused styles should work back down the branches. The macro as it stands only does one pass of a dependency tree branch per run and it is necessary to repeat until there are zero styles deleted.

It is easy to re-run the macro as it is rare to find trees with more than three or four levels. Otherwise it would be simple to add a loop that repeats until zero styles are deleted.

I do have a recursive version of the macro which is larger and more complicated and I have used it on documents that have been created from a department’s template containing over 300 custom styles.

To Ken Endacott

Thank you so much for your brilliant macro. It really speeds things up.

One thing I don't understand. When I ran the macro it deleted 28 styles. But I knew there were still unused styles. So I reran the macro, This time it deleted 8 styles. The third time it deleted 7 styles. The fourth time it deleted 1 style. I am thinking of modifying your macro, so it reruns until 0 styles are deleted.

Any help you can provide is very much appreciated.

Thanks in advance.

re removing unused styles - brilliant !

Hi, I have a conundrum that I don't know how to solve and was wondering if any of you could help me. I have been working on a project that involves about 150 different Word files, all of which I had formatted with about 20 styles in a template attached to each document. I recently merged all the documents into a master file in order to have consecutive paragraph numbering, while keeping the files separate. When all subdocuments are expanded the file is 1,600 pages long and 90,000 words, including thousands of footnotes. In the process of creating the master document, multiple copies of every single style appeared in all the subdocuments . I now need to find a way to restore the original template and remove all these extraneous styles. I tried creating the macro in this thread to delete unused styles but received different error messages at each attempt. Does anyone know of a fix to this problem? Manually changing the styles and deleting each copied style will horribly time consuming.

Thank you very much Ken!

You asked for it.

Sub DeleteUnusedStyles()
Dim oStyle As Style
Dim sCount As Long
sCount = 0
For Each oStyle In ActiveDocument.Styles
'Only check out non-built-in styles
If oStyle.BuiltIn = False Then
If StyleInUse(oStyle.NameLocal) = False Then
Application.OrganizerDelete Source:=ActiveDocument.FullName, _
Name:=oStyle.NameLocal, Object:=wdOrganizerObjectStyles
sCount = sCount + 1
End If
End If
Next oStyle
MsgBox sCount & " styles deleted"
End Sub

Function StyleInUse(Styname As String) As Boolean
' Is Stryname used any of ActiveDocument's story
Dim Stry As Range
Dim Shp As Shape
Dim txtFrame As TextFrame
If Not ActiveDocument.Styles(Styname).InUse Then StyleInUse = False: Exit Function
' check if Currently used in a story?
For Each Stry In ActiveDocument.StoryRanges
If StoryInUse(Stry) Then
If StyleInUseInRangeText(Stry, Styname) Then StyleInUse = True: Exit Function
For Each Shp In Stry.ShapeRange
Set txtFrame = Shp.TextFrame
If Not txtFrame Is Nothing Then
If txtFrame.HasText Then
If txtFrame.TextRange.Characters.Count > 1 Then
If StyleInUseInRangeText(txtFrame.TextRange, Styname) Then StyleInUse = True: Exit Function
End If
End If
End If
Next Shp
End If
Next Stry
StyleInUse = False ' Not currently in use.
End Function

Function StyleInUseInRangeText(rng As Range, Styname As String) As Boolean
' Returns True if "Styname" is use in rng
With rng.Find
.ClearFormatting
.ClearHitHighlight
.Style = Styname
.Format = True
.Text = ""
.Replacement.Text = ""
.Wrap = wdFindContinue
StyleInUseInRangeText = .Execute
End With
End Function

Function StoryInUse(Stry As Range) As Boolean
' Note: this will mark even the always-existing stories as not in use if they're empty
If Not Stry.StoryLength > 1 Then StoryInUse = False: Exit Function
Select Case Stry.StoryType
Case wdMainTextStory, wdPrimaryFooterStory, wdPrimaryHeaderStory: StoryInUse = True
Case wdEvenPagesFooterStory, wdEvenPagesHeaderStory: StoryInUse = Stry.Sections(1).PageSetup.OddAndEvenPagesHeaderFooter = True
Case wdFirstPageFooterStory, wdFirstPageHeaderStory: StoryInUse = Stry.Sections(1).PageSetup.DifferentFirstPageHeaderFooter = True
Case wdFootnotesStory, wdFootnoteContinuationSeparatorStory: StoryInUse = ActiveDocument.Footnotes.Count > 1
Case wdFootnoteSeparatorStory, wdFootnoteContinuationNoticeStory: StoryInUse = ActiveDocument.Footnotes.Count > 1
Case wdEndnotesStory, wdEndnoteContinuationSeparatorStory: StoryInUse = ActiveDocument.Endnotes.Count > 1
Case wdEndnoteSeparatorStory, wdEndnoteContinuationNoticeStory: StoryInUse = ActiveDocument.Endnotes.Count > 1
Case wdCommentsStory: StoryInUse = ActiveDocument.Comments.Count > 1
Case wdTextFrameStory: StoryInUse = ActiveDocument.Frames.Count > 1
Case Else: StoryInUse = False ' Must be some new or unknown wdStoryType
End Select
End Function

if it is not a big ask, can someone please compile the latest suggestion in a code snipped that one can just copy and paste into VBA project - from Sub to End Sub - you know, for those who can't really figure this out just yet but still want to use it.
Much appreciated!

Find in VBA only searches the current story whereas manual Find & Replace searches the whole document. While it would be too tedious to use manual F&R for each custom style, a quick and dirty method would be to use a small macro to delete all custom styles that don’t have their InUse flag set then use manual F&R to test the remainder, not bothering to test styles that are obviously used. Overcomes the need to have complex VBA code and fixes the issue of nested story ranges and unused story.
------------------------------------------------
The ActiveDocument.Shapes statement only gives shapes in the body. To check all shapes in the document you need to put the shape test coding inside the Stry loop. Also, the current code will raise an error with some types of shapes. The StyleInUse function should be:

Function StyleInUse(Styname As String) As Boolean
' Is any of ActiveDocument's text formatted as "Styname"?
Dim Stry As Range
Dim Shp As Shape
Dim txtFrame As TextFrame
' Ever in use?
If Not ActiveDocument.Styles(Styname).InUse Then StyleInUse = False: Exit Function

' Currently used in a story?
For Each Stry In ActiveDocument.StoryRanges
If StoryInUse(Stry) Then
If StyleInUseInRangeText(Stry, Styname) Then StyleInUse = True: Exit Function
End If
For Each Shp In Stry.ShapeRange
Set txtFrame = Shp.TextFrame
If Not txtFrame Is Nothing Then
If txtFrame.HasText Then
If txtFrame.TextRange.Characters.Count > 1 Then
If StyleInUseInRangeText(txtFrame.TextRange, Styname) Then StyleInUse = True: Exit Function
End If
End If
End If
Next Shp
Next Stry

Oops, I was just looking over the post Ken Endacott referenced and realize that it did deal with the issue of shape text, but not the unused story problem, and that I overlooked dealing with the nested story ranges problem.

I thought people might be interested in some functions I use in my own "DeleteUnusedStyles" implementation. I note the Greg Maxey method of searching all stories is a good starting point, but I think it has two problems : 1) it doesn't check text associated with shapes, and 2) it will pick up "orphaned text" that is stories that are not in use, e.g., in a first-page-footer in a section that doesn't have the different-first-page-footer setting set.

Andy.

Function StyleInUseInRangeText(rng As Range, Styname As String) As Boolean
' Is any of "rng" formatted as "styname"?
With rng.Find
.ClearFormatting
.ClearHitHighlight
.Style = Styname
.Format = True
.Text = ""
.Replacement.Text = ""
.Wrap = wdFindContinue
StyleInUseInRangeText = .Execute
End With
End Function

Function StoryInUse(Stry As Range) As Boolean
' Heuristically, is the specified story in actual use?
' Note: this will mark even the always-existing stories as not in use if they're empty
If Not Stry.StoryLength > 1 Then StoryInUse = False: Exit Function
Select Case Stry.StoryType
Case wdMainTextStory, wdPrimaryFooterStory, wdPrimaryHeaderStory: StoryInUse = True
Case wdEvenPagesFooterStory, wdEvenPagesHeaderStory: StoryInUse = Stry.Sections(1).PageSetup.OddAndEvenPagesHeaderFooter = True
Case wdFirstPageFooterStory, wdFirstPageHeaderStory: StoryInUse = Stry.Sections(1).PageSetup.DifferentFirstPageHeaderFooter = True
Case wdFootnotesStory, wdFootnoteContinuationSeparatorStory: StoryInUse = ActiveDocument.Footnotes.Count > 1
Case wdFootnoteSeparatorStory, wdFootnoteContinuationNoticeStory: StoryInUse = ActiveDocument.Footnotes.Count > 1
Case wdEndnotesStory, wdEndnoteContinuationSeparatorStory: StoryInUse = ActiveDocument.Endnotes.Count > 1
Case wdEndnoteSeparatorStory, wdEndnoteContinuationNoticeStory: StoryInUse = ActiveDocument.Endnotes.Count > 1
Case wdCommentsStory: StoryInUse = ActiveDocument.Comments.Count > 1
Case wdTextFrameStory: StoryInUse = ActiveDocument.Frames.Count > 1
Case Else: Debug.Assert False ' Must be some new or unknown wdStoryType
End Select
End Function

Function StyleInUse(Styname As String) As Boolean
' Is any of ActiveDocument's text formatted as "Styname"?

Dim Stry As Range
Dim Shp As Shape

' Ever in use?
If Not ActiveDocument.Styles(Styname).InUse Then StyleInUse = False: Exit Function

' Currently used in a story?
For Each Stry In ActiveDocument.StoryRanges
If StoryInUse(Stry) Then
If StyleInUseInRangeText(Stry, Styname) Then StyleInUse = True: Exit Function
End If
Next Stry

' Currently used in a shape?
For Each Shp In ActiveDocument.Shapes
If Shp.TextFrame.HasText Then
If Shp.TextFrame.TextRange.Characters.Count > 1 Then
If StyleInUseInRangeText(Shp.TextFrame.TextRange, Styname) Then StyleInUse = True: Exit Function
End If
End If
Next Shp

StyleInUse = False ' Not currently in use.
End Function

CORRECTION

The document source name in the Organizer statement depends on whether the document has been saved. The macro with a count of deletions should be:

Sub DeleteUnusedStyles()
Dim oStyle As Style
Dim DocName As String
Dim k As Long

DocName = ActiveDocument.Path & "\" & ActiveDocument.Name
If Left(DocName, 1) = "\" Then DocName = Mid(DocName, 2)
k = 0
For Each oStyle In ActiveDocument.Styles
'Only check out non-built-in styles
If oStyle.BuiltIn = False Then
With ActiveDocument.Content.Find
.ClearFormatting
.Style = oStyle.NameLocal
.Execute FindText:="", Format:=True
If .Found = False Then
Application.OrganizerDelete Source:=DocName, _
Name:=oStyle.NameLocal, Object:=wdOrganizerObjectStyles
k = k + 1
End If
End With
End If
Next oStyle
MsgBox Str(k) & " styles deleted"
End Sub

Paul

The statement oStyle.Delete is painfully slow. A faster way is to use VBA to invoke the Organizer. An example document with 200 unused custom styles to remove, the time taken was reduced from 45 minutes to 30 seconds.

Replace the line:
If .Found = False Then oStyle.Delete

with:
If .Found = False then _
Application.OrganizerDelete Source:=Source:=ActiveDocument.Name, _
Name:=oStyle.NameLocal, Object:=wdOrganizerObjectStyles

I am working on one of these 3GPP Standard specification documents, some of which contain a ridiculous number of unused styles.

Deleting them with VBA is painfully slow, and frankly, I don't really see much performance improvement in terms of Word responsiveness in Layout view mode, so why bother in such case.

My comment is in response to Ken Endacott's suggested modification to the posted macro.

Ken: For those of us who are most probably not as well-versed as you and Allen obviously are, it would be helpful if you could perhaps indicate how the commands from your modification dovetail with the originally posted macro.

In other words, does your command replace a command within the original macro, and if that is indeed the case, what command(s) does it replace; or is it a command that works in conjunction with any of the original commands?

I personally have always found it to be more helpful if an involved party were to post a macro in its entirety, replete with any suggested modification(s).

Aside from that, much appreciation goes out to you and to Allen for all that you do. I cannot even begin to verbalize how very much my work product has been enhanced by the input from the both of you, in addition to other contributors to this site.

Sincerely - Mitch

Ed

The original DeleteUnusedStyles macro and your version use the command oStyle.Delete which is inefficient and can lead to very long execution times when a number of styles are to be deleted. A much more efficient command is:

Application.OrganizerDelete Source:=docPath, _
Name:=styleName, Object:=wdOrganizerObjectStyles

Thanks so much for these tips. I've found them very helpful over the years.

Recently I've been hitting a strange Word 2016 bug that with some documents on some workstations results in the Word error message "There is insufficient memory or disk space. Word cannot display the requested font." In fact there are gigabytes of free main memory and hundreds of gigabytes of free disk space. I've begun to suspect it might have to do with a broken style in the document, and after a little searching I found this DeleteUnusedStyles macro.

The good news: the macro seems to head in the right direction. The bad news: as others have noted, it misses uses in headers and footers, and perhaps other uses as well. Inspired by some code in stackoverflow.com I cobbled together a modification that seems to catch uses in headers and footers as well:

*********

Sub DeleteUnusedStyles()
'
' DeleteUnusedStyles Macro
'
'
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape
Dim oStyle As Style
Dim continue As Boolean
Dim styleTextFound As Boolean
Dim mbResult As Integer

'Fix the skipped blank Header/Footer problem
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType

continue = True
For Each oStyle In ActiveDocument.Styles
' Only check non-built-in styles
If continue And (oStyle.BuiltIn = False) Then
styleTextFound = False
For Each rngStory In ActiveDocument.StoryRanges

'Iterate through all linked stories
Do
If Not styleTextFound Then
With rngStory.Find
.ClearFormatting
.Style = oStyle.NameLocal
.Execute FindText:="", Format:=True
styleTextFound = .Found
End With
End If
On Error Resume Next
Select Case rngStory.StoryType
Case WdStoryType.wdEvenPagesHeaderStory, _
WdStoryType.wdPrimaryHeaderStory, _
WdStoryType.wdEvenPagesFooterStory, _
WdStoryType.wdPrimaryFooterStory, _
WdStoryType.wdFirstPageHeaderStory, _
WdStoryType.wdFirstPageFooterStory
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If Not styleTextFound And oShp.TextFrame.HasText Then
With oShp.TextFrame.TextRange.Find
.ClearFormatting
.Style = oStyle.NameLocal
.Execute FindText:="", Format:=True
styleTextFound = .Found
End With
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0

'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next

mbResult = MsgBox("Delete " & IIf(styleTextFound, "used", "unused") & " style " & oStyle.NameLocal & "?", vbYesNoCancel)
If mbResult = vbCancel Then continue = False
If mbResult = vbYes Then oStyle.Delete
End If
Next oStyle

End Sub

****************

Unfortunately this also deletes any header and footer styles and styles that are in textboxes. I can't come up with a workaround for this.

Allen,
This macro worked like a charm. Thank you so much!
John Seiver

@Judi Pillsbury: The styles to be deleted are listed in StylesArray. You may either operate on StylesArray directly (create a dialog where you can check the styles to be [not] deleted) or include a user request just before deleting the individual style, i.e. line

If StyleStatus(k) = False Then
Application.OrganizerDelete Source:=docPath, _
Name:=StyleArray(k), Object:=wdOrganizerObjectStyles
End If

@Ken Endacott: There is a backslash missing in your code:

docPath = ActiveDocument.Path & "" & ActiveDocument.Name

should read

docPath = ActiveDocument.Path & chr(92) & ActiveDocument.Name

(I expect, this is a character checking and stripping problem of the webserver. To circumvent this, I coded the backslash. Instead of "chr(92)" a simple backslash may be included between the quotation marks.)

Is there a way to run this - or a similar - macro and select which styles to delete without deleting all unused styles?

Thank you. I will read that this weekend, and then use it.

Julian. The following subroutine DeleteUnusedStyles uses your suggested method to check for base styles and then delete unused styles. To determine if a style is used in a document I have used a variation on code, suggested by Greg Maxey, to search every part of a document including text frames in shapes (including textboxes) given in http://word.mvps.org/faqs/customization/ReplaceAnywhere.htm

The code is reasonably efficient, on a 505 page document with 116 custom styles of which 92 were unused, it took 150 seconds to build up a list of styles to be deleted then 97 seconds to delete the 92 styles. On a 145 page document with 33 unused styles out of 54 the times were 34 seconds and 11 seconds.

I hope that it will run on your Mac as it has some work arounds to overcome bugs in VBA.

Now for my gripes about VBA.
1. The Styles pane in Word has an option to display only styles used in the document but it is not possible to access this list in VBA. It would simplify the macro and speed things up considerably.
2. Find in VBA works differently from manual Find and a macro recorded from the manual Find will give different results than the actions that created the macro. Manual Find searches all of the document at once but VBA Find searches only the text in the current story. Furthermore, it does not search in textboxes unless you individually search the contents of each text box.
3. With collections it is not possible to read the key of a collection item. The work around is to construct a parallel array of keys. A small issue, but annoying.
4. The Style.Delete is very inefficient and if used to delete 92 styles results in a blow out of the time from about 1.5 minutes to 30 minutes. Instead the poorly documented Application.OrganizerDelete method is used.

Sub DeleteUnusedStyles()
Dim CustomStyles As New Collection
Dim StyleStatus() As Boolean
Dim StyleArray() As String
Dim aStyle As Style
Dim refStyle As String
Dim k As Long
Dim j As Long
Dim s As String
Dim docPath As String
Dim sCount As Long
Dim loopTest As Boolean

' create collection of custom styles -------------
ReDim StyleArray(0)
k = 0
For Each aStyle In ActiveDocument.Styles
If Not aStyle.BuiltIn Then
k = k + 1
j = CustomStyles.Count
On Error Resume Next
CustomStyles.Add Item:=k, Key:=aStyle.NameLocal
If j = CustomStyles.Count Then
k = k - 1
Else
ReDim Preserve StyleArray(k)
StyleArray(k) = aStyle.NameLocal
End If
End If
On Error GoTo 0
Next aStyle

' First pass. Flag used styles -----------------------
sCount = CustomStyles.Count
ReDim StyleStatus(CustomStyles.Count)
For k = 1 To sCount
StyleStatus(k) = CheckStyleUse(StyleArray(k))
Next k

' subsequent passes. loop until there are no changes -------------------
Do
loopTest = True
For k = 1 To sCount
If StyleStatus(k) Then
On Error Resume Next
refStyle = ActiveDocument.Styles(CustomStyles(k)).BaseStyle.NameLocal
j = 0
j = CustomStyles(refStyle)
If j > 0 Then
If StyleStatus(j) = False Then
StyleStatus(j) = True
loopTest = False
End If
End If
End If
Next k
Loop Until loopTest
On Error GoTo 0

' delete styles that are not used and are not base styles
j = 0
s = ""
For k = 1 To sCount
If StyleStatus(k) = False Then
j = j + 1
s = s & StyleArray(k) & vbCrLf
End If
Next k
s = Str(j) & " styles to be deleted from " & Str(sCount) & vbCrLf & s

If MsgBox(s, vbOKCancel) = vbOK Then
docPath = ActiveDocument.Path & "" & ActiveDocument.Name
For k = 1 To sCount
If StyleStatus(k) = False Then
Application.OrganizerDelete Source:=docPath, _
Name:=StyleArray(k), Object:=wdOrganizerObjectStyles
End If
Next k
End If
End Sub

Function CheckStyleUse(styName As String) As Boolean
Dim aRange As Range
Dim aShape As Shape
Dim m As Long
CheckStyleUse = False
m = ActiveDocument.Sections(1).Headers(1).Range.StoryType
For Each aRange In ActiveDocument.StoryRanges
Do
If FindStyleInRange(aRange, styName) Then
CheckStyleUse = True
Exit Function
End If
' check any textboxes in story
On Error Resume Next
Select Case aRange.StoryType
Case 6, 7, 8, 9, 10, 11
If aRange.ShapeRange.Count > 0 Then
For Each aShape In aRange.ShapeRange
If aShape.TextFrame.HasText Then
If FindStyleInRange(aShape.TextFrame.TextRange, styName) Then
CheckStyleUse = True
Exit Function
End If
End If
Next
End If
End Select
Set aRange = aRange.NextStoryRange
Loop Until aRange Is Nothing
Next aRange
On Error GoTo 0
End Function

Function FindStyleInRange(aRange As Range, styName As String) As Boolean
With aRange.Find
.ClearFormatting
.Style = styName
.Text = ""
.Replacement.Text = ""
.Wrap = wdFindContinue
FindStyleInRange = .Execute
End With
End Function

My first method was slower than necessary.

• Create an array of all non-built-in styles.
• Create a same-length Boolean array, defaulting to False.
• For Each st in styles.
•• If st used, loop forever:
••• Mark st as True
••• If st has no ancestor then Exit Loop forever else st = Ancestor(st);
•• End Loop forever
•• Next st
• Delete all styles still False.

If you write this (Mac Word doesn’t show object model, so writing it would be painful for me), please share.

Julian
I have been using an elaborate method to ensure that ancestor styles of active styles are not deleted but your suggestion is a more elegant way of handling chained dependencies.

What if a style is not used directly, but another style is based-on this unused style? It seems that DeleteUnusedStyles() would delete this ancestor style, but shouldn’t.

An algorithm might proceed as follows.
• Create an array of all non-built-in styles.
• Create a same-length Boolean array, defaulting to False.
• Make all used styles as True.
• Mark the immediate ancestor of all True styles as True. Repeat until this ceases to cause any changes.
• Delete all False styles.

To get Jason's script to work, I had to make the following changes

Dim dicAllStyleNames As Scripting.Dictionary
Dim dicUsedStyleNames As Scripting.Dictionary

becomes

Dim dicAllStyleNames As Object
Dim dicUsedStyleNames As Object

Note that Jason’s version below will not work on a Mac, for several reasons:

1.

The Scripting library (and thus Dictionaries) is not available in OS X. A workaround is to use Patrick O’Beirne’s Dictionary Class: https://sysmod.wordpress.com/2011/11/02/dictionary-class-in-vba-instead-of-scripting-dictionary/

This works more or less painlessly, but there are a few caveats, such as the Add method of Patrick’s Dictionary Class (DC) expecting the key as a String, not a Variant.

(Note: I haven’t managed to get DC working properly in Office 2016—it keeps complaining about type mismatches and I can’t figure out where they’re coming from. It works in Office 2011.)




2.

The code used for Application.OrganizerDelete will not work as posted. The variable docPath is set to ActiveDocument.Path & "" & ActiveDocument.Name, which won’t work for two reasons.

First off, a hard-coded backslash will be Windows-only—the better way to do it is the way sFilePath is defined further up in the code, by using Application.PathSeparator (it will be “:” on a Mac, not “”).

Secondly, at least on a Mac, ActiveDocument.Path already contains the entire path including the name, so adding an extra path separator and document name will yield a path to a nonexistent file (“computer:Users:Username:Documents:DocumentName.docx:DocumentName.docx”, for example).




You’ll have to tinker with it a good deal to get it to work on Office for Mac.

Ooops! Yes, indeed.
Thanks again Ken.

Jason

I think that the reason objStyle.Namelocal is evaluating incorrectly is that you have declared
Dim objStyle as Object

rather than
Dim objStyle as Style

If you declare variables as Object or Variant, Word gives the variable a suitable attribute the first time the variable is used. I suspect that during your testing somehow objStyle had acquired a different attribute that remained during further testing.

Anyway, your solution has fixed the problem.

Hi Ken,

For some reason, the Name:=objStyle.NameLocal field keeps evaluating to "Microsoft Word" in your code running on a Word 2010 document in Word 2010.

By simply substituting the key value of the loop (below), the new delete code worked.

Application.OrganizerDelete Source:=docPath, _
name:=key, Object:=wdOrganizerObjectStyles

The complete new listing is given below with debug statements removed and your fix included.

Cheers,
Jason

==================== BEGIN CODE =============================

Sub RemoveDeadStyles()

On Error GoTo ErrorHandler

Const MAX_SAVE_WAIT As Integer = 50 ' # deletes between saves
Const MAX_UNDO_WAIT As Integer = 20 ' # deletes between undo buffer purges

Dim i As Long

Dim pCount As Integer
Dim changeCounter As Integer
Dim activeStyleCount As Integer

Dim sName As String

Dim dicAllStyleNames As Scripting.Dictionary
Dim dicUsedStyleNames As Scripting.Dictionary

Set dicAllStyleNames = CreateObject("scripting.dictionary")
Set dicUsedStyleNames = CreateObject("scripting.dictionary")

Dim colParagraphs As Word.paragraphs
Dim colActiveStyles As Word.Styles

Dim pStyleObj As Style

Dim p As paragraph

Dim objStyleName As Variant
Dim uniqueUsedStyles As Variant

Dim objStyle As Object

Set colActiveStyles = ActiveDocument.Styles
Set colParagraphs = ActiveDocument.paragraphs

activeStyleCount = colActiveStyles.Count
pCount = colParagraphs.Count

Dim sFilePath As String
sFilePath = ActiveDocument.Path & Application.PathSeparator & ActiveDocument.name

' Get all ACTIVE style names as strings

Word.System.Cursor = wdCursorWait
Word.StatusBar = "Scanning document for all ACTIVE style names.."

For i = 1 To colActiveStyles.Count
Set objStyle = colActiveStyles.Item(i)
sName = objStyle.NameLocal
dicAllStyleNames.Add sName, ""
Set objStyle = Nothing
Word.StatusBar = "Scanning document for all ACTIVE style names.." & "Adding style[" & i & "]=" & sName
Next

Word.StatusBar = "dicAllStyleNames count: " & dicAllStyleNames.Count


' Scan document paragraphs for all USED styles and get names

Word.StatusBar = "Scanning document paragraphs for all USED style names.."

Dim localName As String

For i = 1 To pCount
Set p = colParagraphs.Item(i)
Set objStyle = p.Style

If Not objStyle Is Nothing Then
localName = objStyle.NameLocal
dicUsedStyleNames.Add localName, ""
Word.StatusBar = "Scanning document paragraphs for all USED style names.. Adding " & localName
End If

Set p = Nothing
Set objStyle = Nothing
Next i

Word.StatusBar = "dicUsedStyleNames size:" & dicUsedStyleNames.Count

Dim usedStyleKeys As Variant
Dim key As Variant
usedStyleKeys = dicUsedStyleNames.Keys

' Remove used styles from all styles collection

For Each key In usedStyleKeys
Word.StatusBar = "Filtering used style: " & key
dicAllStyleNames.Remove key
Next

Word.StatusBar = "All remaining styles count: " & dicAllStyleNames.Count


' Remove all dead styles

changeCounter = 0

Dim newKeys As Variant
Dim docPath As String

docPath = ActiveDocument.Path & "" & ActiveDocument.name
newKeys = dicAllStyleNames.Keys

For Each key In newKeys

Set objStyle = ActiveDocument.Styles.Item(key)

If objStyle.BuiltIn = False Then
Word.StatusBar = "Removed style: " & key

' Obsolete approach
'objStyle.Delete

'Application.OrganizerDelete Source:=docPath, name:=objStyle.NameLocal, Object:=wdOrganizerObjectStyles
Application.OrganizerDelete Source:=docPath, name:=key, Object:=wdOrganizerObjectStyles

changeCounter = changeCounter + 1
End If

Set objStyle = Nothing

' You want to save frequently enough that incremental changes are preserved
' but not so fast that you slow the macro. Also you want to purge the
' undo buffer but not before it has filled up enough to cause a performance
' problem. This macro impl uses the MAX_SAVE_WAIT value as a compromise.

If (changeCounter > 0) And ((changeCounter Mod MAX_SAVE_WAIT) = 0) Then
Word.StatusBar = "Saving changes..."
ActiveDocument.Save
DoEvents
ActiveDocument.UndoClear
End If

Next key

MsgBox "All unused styles removed OK!" & vbCrLf & "New Style Count: " & ActiveDocument.Styles.Count, vbOKOnly
Word.StatusBar = "All unused styles removed OK!" & " New Style Count: " & ActiveDocument.Styles.Count

Word.System.Cursor = wdCursorNormal


Exit Sub
ErrorHandler:
'Debug.Print "ERROR: " & Err.Description & " Err Num = " & Err.Number & " " & Err.Source
If (Err.Number = 457) Then
Resume Next
ElseIf (Err.Number = 6015) Then
Word.StatusBar = "Closing on corruption error. Reopen and fix."
ActiveDocument.Close (True)
DoEvents
ElseIf (Err.Number = 4605) Then
Resume Next
End If
End Sub

==================== END CODE =============================

Hi Ken,
A nice improvement!

I was happy just to get the bloody thing to work! I had a 300 page thesis that was utterly wrecked with thousands of unused styles.

I will post an updated solution.

Cheers,
Jason

Jason
Your method of using the scripting dictionary object is efficient for determining unused styles. However, to delete styles you use the very inefficient statement:
objStyle.Delete

A much better statement is:
Application.OrganizerDelete Source:=docPath, _
Name:=objStyle.NameLocal, Object:=wdOrganizerObjectStyles

Where docPath is set outside the loop to:
docPath = ActiveDocument.Path & "" & ActiveDocument.Name

On a sample document that has 757 total styles of which 461 are unused, your macro took 567 seconds. The modified macro with the more efficient delete took 51 seconds.

What many of these solutions do is scan the document one time for a each style. This is terribly inefficient for large documents and large numbers of styles. A more efficient approach is to use the scripting Dictionary object and its ability to enforce unique keys. I propose the following solution:

1. Get a collection of all active styles in the document (1st pass).
2. Get a collection of all used styles in the document by checking each paragraph (2nd pass).
3. For each element of the used styles, if it's not a built-in style, then eliminate it from the active collection. The remaining collection is the set of totally unused styles to be deleted.
4. Delete this collection.

WARNING: This can be a long-running process for big documents with many paragraphs and/or many styles. Switch to immediate mode to see progress.

Sub RemoveDeadStyles()

On Error GoTo ErrorHandler

Dim i As Long
Dim pCount As Integer

Dim sName As String

Dim dicAllStyleNames As Scripting.dictionary
Dim dicUsedStyleNames As Scripting.dictionary

Set dicAllStyleNames = CreateObject("scripting.dictionary")
Set dicUsedStyleNames = CreateObject("scripting.dictionary")

Dim colParagraphs As word.Paragraphs
Dim colActiveStyles As word.Styles

Dim activeStyleCount As Integer

Dim pStyleObj As Style

Dim p As Paragraph

Dim objStyleName As Variant
Dim objStyle As Object
Dim uniqueUsedStyles As Variant

Set colActiveStyles = ActiveDocument.Styles
Set colParagraphs = ActiveDocument.Paragraphs

activeStyleCount = colActiveStyles.Count
pCount = colParagraphs.Count

Debug.Print "Active Style Count: " & activeStyleCount
Debug.Print "Paragraph Count: " & pCount

' Get all ACTIVE style names as strings
For i = 1 To colActiveStyles.Count
Set objStyle = colActiveStyles.Item(i)
sName = objStyle.NameLocal
dicAllStyleNames.Add sName, ""
Set objStyle = Nothing
Debug.Print "Adding style[" & i & "]=" & sName
DoEvents
Next

Debug.Print "=================================================="
Debug.Print "All active style names scanned OK..."
Debug.Print "dicAllStyleNames count: " & dicAllStyleNames.Count

' Scan document paragraphs for all USED styles and get names
For i = 1 To pCount
Set p = colParagraphs.Item(i)
Set objStyle = p.Style

If Not objStyle Is Nothing Then
dicUsedStyleNames.Add objStyle.NameLocal, ""
End If
Set p = Nothing
Set objStyle = Nothing
DoEvents
Next i


Debug.Print "=================================================="
Debug.Print "All used paragraph style names scanned OK..."
Debug.Print "dicUsedStyleNames size:" & dicUsedStyleNames.Count


Dim usedStyleKeys As Variant
Dim key As Variant
usedStyleKeys = dicUsedStyleNames.Keys

' Remove used styles from all
For Each key In usedStyleKeys
dicAllStyleNames.Remove key
DoEvents
Next

Debug.Print "=================================================="
Debug.Print "All unique used style names removed from all names OK..."
Debug.Print "All remaining styles count: " & dicAllStyleNames.Count

i = 0

' Get the new keys
Dim newKeys As Variant
newKeys = dicAllStyleNames.Keys

' Remove the dead styles
For Each key In newKeys

Set objStyle = ActiveDocument.Styles.Item(key)

If objStyle.BuiltIn = False Then
Debug.Print "Removing " & objStyle
objStyle.Delete
End If

Set objStyle = Nothing

i = i + 1

' Clear the undo buffer
If ((i Mod 25) = 0) Then
ActiveDocument.UndoClear
Debug.Print vbTab & vbTab & "Cleared undo buffer..."
End If

DoEvents

Next key


Debug.Print "================================================"
Debug.Print "All unused styles removed OK!"
Debug.Print "New Style Count: " & ActiveDocument.Styles.Count
Debug.Print "================================================"


Exit Sub
ErrorHandler:
Debug.Print "ERROR: " & Err.Description & " Err Num = " & Err.Number & " " & Err.Source
' This is the error that the key already exists... just swallow that.
If (Err.Number = 457) Then
Resume Next
End If
End Sub

Toby. Your macro does not look at style usage in other than the main story and hence may remove styles that are in use.

The following is a macro that will check for style usage in all story parts of the document. Rather than look at the style of every paragraph it uses Find to see if each custom style is used at least once. This is quicker on large documents.

Sub DeleteUnusedStyles()
Dim oRange As Range
Dim aRange As Range
Dim styy As Style
Dim sName As String
Dim docPath As String
Dim Customstyle() As String
Dim j As Long
Dim jj As Long
Dim k As Long

' build array of custom styles
ReDim Customstyle(0)
j = -1
For Each styy In ActiveDocument.Styles
With styy
If Not .BuiltIn And .Type <> wdStyleTypeTable And _
.Type <> wdStyleTypeList Then
j = j + 1
ReDim Preserve Customstyle(j)
Customstyle(j) = .NameLocal
End If
End With
Next styy
If j < 0 Then
MsgBox "No custom styles"
Exit Sub
End If

' remove custom style from array if it is used
For Each oRange In ActiveDocument.StoryRanges
jj = 0
Do
Set aRange = oRange.Duplicate
With aRange.Find
.ClearFormatting
.Style = Customstyle(jj)
End With
If aRange.Find.Execute(FindText:="", replacewith:="", MatchCase:=False, Wrap:=wdFindStop, _
MatchWholeWord:=False, Forward:=False, Replace:=wdReplaceNone) Then
For k = jj To j - 1
Customstyle(k) = Customstyle(k + 1)
Next k
j = j - 1
Else
jj = jj + 1
End If
Loop Until jj > j
Next oRange

If j < 0 Then
MsgBox "All custom styles are in use"
Exit Sub
Else
If MsgBox("There are " & j + 1 & " unused custom styles. Remove them?", vbYesNo) = vbNo Then Exit Sub
End If
' Delete custom styles that left in array
docPath = ActiveDocument.Path & "" & ActiveDocument.Name
For k = 0 To j
Application.OrganizerDelete Source:=docPath, _
Name:=Customstyle(k), Object:=wdOrganizerObjectStyles
Next k

End Sub

To go with my previous comment. This is the macro we use:

Sub StyleBloatFix()
Dim StyleList As Collection
Dim ActiveParagraph As Paragraph
Dim ActiveTable As Table
Dim ActiveStyle As Style
Dim exists As Boolean
Dim x As Long

On Error Resume Next

Set StyleList = New Collection

For Each ActiveParagraph In ActiveDocument.Paragraphs
exists = False

For x = 1 To StyleList.Count
If ActiveParagraph.Style.NameLocal = StyleList(x) Then
exists = True
Exit For
End If
Next

If Not exists Then
StyleList.Add Item:=ActiveParagraph.Style.NameLocal
End If
Next ActiveParagraph

For Each ActiveTable In ActiveDocument.Tables
exists = False

For x = 1 To StyleList.Count
If ActiveTable.Style.NameLocal = StyleList(x) Then
exists = True
Exit For
End If
Next

If Not exists Then
StyleList.Add Item:=ActiveTable.Style.NameLocal
End If
Next ActiveTable

For Each ActiveStyle In ActiveDocument.Styles
exists = False

If Not ActiveStyle.BuiltIn Then
For x = 1 To StyleList.Count
If ActiveStyle.NameLocal = StyleList(x) Then
exists = True
Exit For
End If
Next

If Not exists Then

Application.OrganizerDelete Source:=ActiveDocument.Path & "" & ActiveDocument.name, name:=ActiveStyle.NameLocal, _
Object:=wdOrganizerObjectStyles
End If
End If
Next ActiveStyle
End Sub

This will:
loop through all paragraphs and create a list of used styles
loop through all tables and create a list of used styles
Loop through all styles in the document and checking if they are on the list
If they are not, delete the style from the document using the organizer

We have actually Identified a bug in MS word. When you run your macro, whether or not the styles are being removed from the style list, they are not being removed from the document; at least, not 100% of the time. Depending on the circumstances your macro can result in a style bloat issue where the styles.xml file of the document blows up.

Open a new document and save it to your desktop. Change the extension to a .zip from a .docx and open the word folder within the zip file. The uncompressed styles.xml file will be rather low.

Now change the extension back to .docx, run the macro and check the uncompressed styles.xml file. For us it usually goes from 15kb to ~ 400kb.

This is because even though you are only comparing strings, word pulls the definition of the style into the document as a frame of reference, then it removes the style from your styles list but leaves the definition in the xml.

Hmm, unfortunately the macro seems to delete table styles that are in use.

Any idea how to check whether table styles are being used?

Viktor

I cannot replicate your problem in Word2010.

What version of Word are you using?

For me, it exits with "item with specified name does not exist" when it tries to set

.Style = oStyle.NameLocal

if namelocal points to an alias that is not really a style name, e.g. "Body text (2) + Arial,7.5 pt,Bold"

How to overcome this please?

Absolutely Brilliant - thankyou!

Documents can accumulate styles and it is not uncommon for a document to have 200 unused custom styles. The oStyle.Delete method has problems if more than a few styles are to be deleted and can take up to 30 minutes to delete 100 styles.

The solution is to use the style organizer which will reduce the time to a few seconds. Instead of oStyle.Delete use:

Application.OrganizerDelete Source:= _
ActiveDocument.Path & "" & ActiveDocument.Name, _
Name:=oStyle.NameLocal, Object:=wdOrganizerObjectStyles

This worked perfectly - thanks

Save it as .RTF, then close it, then open the .RTF in MS Word, and save it again in .DOC format.

Worked with me!

Regards!

Hello. I would like to delete a style that was created by me, not a built-in style. I have tried in 2-3 different ways, but I only manage to remove it from the quick list and only for the document that is open at the time. It appears again in the quick list when I open a new document. Have you got a tip for completely deleting a created style in Word 2007? Thanks very much in advance!

My word 2007 was not able to find ActiveDocument.Content.Find.Style property when used with a String type variable. I had to use a CVar() cast for it to work. I hope this helps other people.

Sub DeleteUnusedStyles()
Dim oStyle As Style

For Each oStyle In ActiveDocument.Styles
'Only check out non-built-in styles
If oStyle.BuiltIn = False Then
With ActiveDocument.Content.Find
.ClearFormatting
.Style = CVar(oStyle.NameLocal)
.Execute FindText:="", Format:=True
If .Found = False Then oStyle.Delete
End With
End If
Next oStyle
End Sub

Thanks so much. This is exactly what I need.

This was useful but its not suitable for vast type files.