I have been trying to write code that cycles through a workbook and removes any unused styles. The workbooks I test the code on are very large (sometimes the .usedrange of all the sheets is 200000 cells) so the code takes an awful long time to run, hours in some cases!

I have thought that it may be faster to use an array to store the style list but wasnt sure how to do that. Basically any ideas that will speed this macro up would be useful.

I know there are 3rd party addins that will do this but you have to pay about £50!

Thanks

Here is the code

Sub ClearUnusedStyles()
    Dim i&, cellInStyleList As Range, RangeOfStyles, CellInUsedRange As Range
    Dim Counter As Integer
    Dim sheet As Worksheet
    Dim ProgressPercent As Integer
    Dim ProgressCounter, TotalRange As Long
         
    Counter = 0
    ProgressCounter = 0
    ProgressPercent = 0
   
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    'Add a temporary sheet
    Sheets.Add before:=Sheets(1)
    
    'List all the styles on the temporary sheet
    For i = 1 To ActiveWorkbook.Styles.Count
        [a65536].End(xlUp).Offset(1, 0) = ActiveWorkbook.Styles(i).Name
    Next
    
    'Give the list of styles a name
    Set RangeOfStyles = Range(Columns(1).Rows(2), Columns(1).Rows(65536).End(xlUp))
    
    'Work out how many cells are used in the workbook for the counter
    For Each sheet In Worksheets
        If sheet.Index > 1 Then
        TotalRange = TotalRange + sheet.UsedRange.Count
        End If
    Next

    'Check the style list against each used cell - if used put a 1 next to it
    For Each sheet In Worksheets
        If sheet.Index > 1 Then

        UserForm1.Show

            For Each CellInUsedRange In sheet.UsedRange
                
                ProgressCounter = ProgressCounter + 1
                ProgressPercent = ProgressCounter / TotalRange * 100
                
                On Error Resume Next
                For Each cellInStyleList In RangeOfStyles
                    If CellInUsedRange.Style = cellInStyleList.Value Then
                        cellInStyleList.Offset(0, 1).Value = 1
                    End If

                    
                    With UserForm1
                    .FrameProgress.Caption = Format(ProgressPercent / 100, "0%")
                    .LabelProgress.Width = ProgressPercent / 100 * (.FrameProgress.Width - 10)
                    End With
                    DoEvents
                
                Next cellInStyleList
  
            Next CellInUsedRange

        End If

    Next sheet

    'Delete all unused styles
    For Each cellInStyleList In RangeOfStyles
            If Not cellInStyleList.Offset(0, 1) = 1 Then
                ActiveWorkbook.Styles(cellInStyleList.Text).Delete
                ActiveWorkbook.Styles(cellInStyleList.NumberFormat).Delete
                Counter = Counter + 1
            End If
    Next cellInStyleList
    
    Unload UserForm1
    Application.DisplayAlerts = False
    ActiveSheet.Delete                              'delete the temp sheet
    Application.Calculation = xlCalculationAutomatic

    MsgBox "I have removed " & Counter & " styles"
    
End Sub