Delete Unused Custom Formats

This procedure provides a workaround for the glaring lack of accessibility in VBA for manipulating custom number formats.
To do this, it hacks into the Number Format dialog box with SendKeys.
It loops through each item, including those custom number formats that have been orphaned from the worksheet.
The dialog box flickers upon each opening, but it works! If anyone comes up with a way to eliminate the flicker, let me know.


Sub DeleteUnusedCustomNumberFormats() 
    Dim Buffer As Object
    Dim Sh As Object
    Dim SaveFormat As Variant
    Dim fFormat As Variant
    Dim nFormat() As Variant
    Dim xFormat As Long
    Dim Counter As Long
    Dim Counter1 As Long
    Dim Counter2 As Long
    Dim StartRow As Long
    Dim EndRow As Long
    Dim Dummy As Variant
    Dim pPresent As Boolean
    Dim NumberOfFormats As Long
    Dim Answer
    Dim c As Object
    Dim DataStart As Long
    Dim DataEnd As Long
    Dim AnswerText As String

    NumberOfFormats = 1000
    ReDim nFormat(0 To NumberOfFormats)
    AnswerText = "Do you want to delete unused custom formats from the workbook?"
    AnswerText = AnswerText & Chr(10) & "To get a list of used and unused formats only, choose No."
    Answer = MsgBox(AnswerText, 259)
    If Answer = vbCancel Then GoTo Finito

    On Error GoTo Finito
    Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = "CustomFormats"
    Worksheets("CustomFormats").Activate
    Set Buffer = Range("A2")
    Buffer.Select
    nFormat(0) = Buffer.NumberFormatLocal
    Counter = 1
    Do
        SaveFormat = Buffer.NumberFormatLocal
        Dummy = Buffer.NumberFormatLocal
        DoEvents
        SendKeys "{tab 3}{down}{enter}"
        Application.Dialogs(xlDialogFormatNumber).Show Dummy
        nFormat(Counter) = Buffer.NumberFormatLocal
        Counter = Counter + 1
    Loop Until nFormat(Counter - 1) = SaveFormat

    ReDim Preserve nFormat(0 To Counter - 2)

    Range("A1").Value = "Custom formats"
    Range("B1").Value = "Formats used in workbook"
    Range("C1").Value = "Formats not used"
    Range("A1:C1").Font.Bold = True

    StartRow = 3
    EndRow = 16384

    For Counter = 0 To UBound(nFormat)
        Cells(StartRow, 1).Offset(Counter, 0).NumberFormatLocal = nFormat(Counter)
        Cells(StartRow, 1).Offset(Counter, 0).Value = nFormat(Counter)
    Next Counter

    Counter = 0
    For Each Sh In ActiveWorkbook.Worksheets
        If Sh.Name = "CustomFormats" Then Exit For
        For Each c In Sh.UsedRange.Cells
            fFormat = c.NumberFormatLocal
            If Application.WorksheetFunction.CountIf(Range(Cells(StartRow, 2), Cells(EndRow, 2)), fFormat) = 0 Then
                Cells(StartRow, 2).Offset(Counter, 0).NumberFormatLocal = fFormat
                Cells(StartRow, 2).Offset(Counter, 0).Value = fFormat
                Counter = Counter + 1
            End If
        Next c
    Next Sh

    xFormat = Range(Cells(StartRow, 2), Cells(EndRow, 2)).Find("").Row - 2
    Counter2 = 0
    For Counter = 0 To UBound(nFormat)
        pPresent = False
        For Counter1 = 1 To xFormat
            If nFormat(Counter) = Cells(StartRow, 2).Offset(Counter1, 0).NumberFormatLocal Then
                pPresent = True
            End If
        Next Counter1
        If pPresent = False Then
            Cells(StartRow, 3).Offset(Counter2, 0).NumberFormatLocal = nFormat(Counter)
            Cells(StartRow, 3).Offset(Counter2, 0).Value = nFormat(Counter)
            Counter2 = Counter2 + 1
        End If
    Next Counter
    With ActiveSheet.Columns("A:C")
        .AutoFit
        .HorizontalAlignment = xlLeft
    End With
    If Answer = vbYes Then
        DataStart = Range(Cells(1, 3), Cells(EndRow, 3)).Find("").Row + 1
        DataEnd = Cells(DataStart, 3).Resize(EndRow, 1).Find("").Row - 1
        On Error Resume Next
        For Each c In Range(Cells(DataStart, 3), Cells(DataEnd, 3)).Cells
            ActiveWorkbook.DeleteNumberFormat (c.NumberFormat)
        Next c
    End If
Finito:
    Set c = Nothing
    Set Sh = Nothing
    Set Buffer = Nothing
End Sub


Public Sub ListAllFormats() 

Dim iwshcount As Integer
Dim objWorksheet As Worksheet
Dim llastrow As Long
Dim ilastcolumn As Integer
Dim lRowNo As Long
Dim icolno As Integer
Dim arUniqueFormats2() As String
Dim objFSODictionary As Scripting.Dictionary
Dim objFSOUniqueTotals As Scripting.Dictionary
Dim objFSOWorksheetNames_Column As Scripting.Dictionary
Dim arUniqueWorksheetKeys As Variant
Dim snumberformat As String
Dim isheetandformatcount As Integer
Dim lcurrentrow As Long
Dim scellpattern As String
Dim scellstyle As String
Dim slastcolchar As String

   On Error GoTo AnError
   ReDim arUniqueFormats2(4, (3000 * ActiveWorkbook.Worksheets.Count)) As String
   Set objFSODictionary = New Scripting.Dictionary
   Set objFSOUniqueTotals = New Scripting.Dictionary
   Set objFSOWorksheetNames_Column = New Scripting.Dictionary

   For iwshcount = 1 To ActiveWorkbook.Worksheets.Count
      Set objWorksheet = ActiveWorkbook.Worksheets(iwshcount)
      If (objWorksheet.Name <> "Sheet1") Then
      
         If (objWorksheet.Visible <> xlSheetVisible) Then
            objWorksheet.Visible = xlSheetVisible
         End If
         If (objFSOWorksheetNames_Column.Exists(objWorksheet.Name) = False) Then
            objFSOWorksheetNames_Column.Add objWorksheet.Name, iwshcount - 1
         End If
      
         objWorksheet.Select
         llastrow = Range("A1").SpecialCells(XlCellType.xlCellTypeLastCell).Row
         ilastcolumn = Range("A1").SpecialCells(XlCellType.xlCellTypeLastCell).Column
              
         For lRowNo = 1 To llastrow
            For icolno = 1 To ilastcolumn
               snumberformat = Cells(lRowNo, icolno).NumberFormatLocal
               Call UniqueFormatsPopulate("Number Format", snumberformat, lRowNo, icolno, objWorksheet.Name, _
                                          objFSODictionary, objFSOUniqueTotals, arUniqueFormats2)
               
               scellpattern = Cells(lRowNo, icolno).Interior.ColorIndex
               Call UniqueFormatsPopulate("Shading Pattern", scellpattern, lRowNo, icolno, objWorksheet.Name, _
                                          objFSODictionary, objFSOUniqueTotals, arUniqueFormats2)
                                          
               scellstyle = Cells(lRowNo, icolno).Style
               Call UniqueFormatsPopulate("Style", scellstyle, lRowNo, icolno, objWorksheet.Name, _
                                          objFSODictionary, objFSOUniqueTotals, arUniqueFormats2)
                          
            Next icolno
         Next lRowNo
      End If
   Next iwshcount
     
   ReDim Preserve arUniqueFormats2(4, objFSOUniqueTotals.Count - 1)
   arUniqueFormats2 = SortArray(arUniqueFormats2)
   Worksheets("Sheet1").Select
   Cells.Clear
   Cells.ClearFormats
        
'display worksheets across the top
   Range("C2").Value = "TOTAL"
   arUniqueWorksheetKeys = objFSOWorksheetNames_Column.Keys()
   For iwshcount = 0 To UBound(arUniqueWorksheetKeys, 1)
      Cells(2, 4 + iwshcount).Value = arUniqueWorksheetKeys(iwshcount)
   Next iwshcount
           
   slastcolchar = Col_Letter(UBound(arUniqueWorksheetKeys, 1) + 4)
           
'display unique formats down left hand side - start by creating a list of unique formats
   llastrow = 3
   llastrow = PopulateTableWithCategory(slastcolchar, objFSODictionary, objFSOWorksheetNames_Column, arUniqueFormats2, "Number Format", llastrow)
   llastrow = llastrow + 2
   llastrow = PopulateTableWithCategory(slastcolchar, objFSODictionary, objFSOWorksheetNames_Column, arUniqueFormats2, "Shading Pattern", llastrow)
   llastrow = llastrow + 2
   llastrow = PopulateTableWithCategory(slastcolchar, objFSODictionary, objFSOWorksheetNames_Column, arUniqueFormats2, "Style", llastrow)
        
    
   Exit Sub
AnError:
   MsgBox (Err.Number & " - " & Err.Description)
End Sub
'**************************************************************************************
Public Sub UniqueFormatsPopulate(ByVal sCategoryName As String, _
                                 ByVal sFormat As String, _
                                 ByVal lRowNo As Long, _
                                 ByVal icolno As Integer, _
                                 ByVal sWshName As String, _
                                 ByRef objFSODictionary As Scripting.Dictionary, _
                                 ByRef objFSOUniqueTotals As Scripting.Dictionary, _
                                 ByRef arUniqueFormats As Variant)

   On Error GoTo AnError

   If (objFSODictionary.Exists(sCategoryName & sWshName & "!!" & sFormat) = True) Then
      objFSODictionary(sCategoryName & sWshName & "!!" & sFormat) = _
         objFSODictionary(sCategoryName & sWshName & "!!" & sFormat) + 1
   
      arUniqueFormats(3, objFSOUniqueTotals(sCategoryName & sWshName & "!!" & sFormat)) = _
         arUniqueFormats(3, objFSOUniqueTotals(sCategoryName & sWshName & "!!" & sFormat)) & "-" & Cells(lRowNo, icolno).Address
   
   Else
      objFSODictionary.Add sCategoryName & sWshName & "!!" & sFormat, 1
      objFSOUniqueTotals.Add sCategoryName & sWshName & "!!" & sFormat, (objFSOUniqueTotals.Count)
   
      arUniqueFormats(0, objFSOUniqueTotals.Count - 1) = sCategoryName
     arUniqueFormats(1, objFSOUniqueTotals.Count - 1) = sWshName
      arUniqueFormats(2, objFSOUniqueTotals.Count - 1) = sFormat
      arUniqueFormats(3, objFSOUniqueTotals.Count - 1) = Cells(lRowNo, icolno).Address
      arUniqueFormats(4, objFSOUniqueTotals.Count - 1) = sCategoryName & sWshName & sFormat
   End If

   Exit Sub
AnError:
   MsgBox (Err.Number & " - " & Err.Description)
End Sub
'**************************************************************************************
Public Function PopulateTableWithCategory(ByVal slastcolchar As String, _
                                          ByVal objFSODictionary As Scripting.Dictionary, _
                                          ByVal objFSOWorksheetNames_Column As Scripting.Dictionary, _
                                          ByVal arUniqueFormats As Variant, _
                                          ByVal sCategory As String, _
                                          ByVal llastrow As Long) As Long
                                          
Dim objFSOUniqueFormats_Rows As Scripting.Dictionary
Dim arUniqueFormatKeys As Variant
Dim lRowNo As Long

   On Error GoTo AnError

   Set objFSOUniqueFormats_Rows = New Scripting.Dictionary
   Set objFSOUniqueFormats_Rows = ReturnUniqueFormatsForACategory(arUniqueFormats, sCategory)
   
   arUniqueFormatKeys = objFSOUniqueFormats_Rows.Keys
   For lRowNo = 0 To UBound(arUniqueFormatKeys, 1)
      Range("A" & lRowNo + llastrow).Value = sCategory
      Range("B" & lRowNo + llastrow).Value = "''" & arUniqueFormatKeys(lRowNo)
      Range("C" & lRowNo + llastrow).Value = "=SUM(D" & lRowNo + llastrow & ":" & _
                                                   slastcolchar & lRowNo + llastrow & ")"
      
      If (sCategory = "Shading Pattern") Then
         If (arUniqueFormatKeys(lRowNo) <> "-4142") Then
            Range("B" & lRowNo + llastrow).Interior.ColorIndex = arUniqueFormatKeys(lRowNo)
         End If
      End If
      
   Next lRowNo
   
   Rows("2:2").Font.Bold = True
   Columns("B:C").Font.Bold = True
'Columns("A").ColumnWidth = 3
   Columns("A:B").EntireColumn.AutoFit
       
   For lRowNo = 0 To UBound(arUniqueFormats, 2)
      If (arUniqueFormats(0, lRowNo) = sCategory) Then
         Cells((llastrow - 1) + objFSOUniqueFormats_Rows.Item(arUniqueFormats(2, lRowNo)), _
               3 + objFSOWorksheetNames_Column.Item(arUniqueFormats(1, lRowNo))).Value = _
            objFSODictionary(sCategory & arUniqueFormats(1, lRowNo) & "!!" & arUniqueFormats(2, lRowNo))
      End If
   Next lRowNo
        
   PopulateTableWithCategory = llastrow + UBound(arUniqueFormatKeys, 1)
        
   Exit Function
AnError:
   MsgBox (Err.Number & " - " & Err.Description)
End Function
'**************************************************************************************
Public Function ReturnUniqueFormatsForACategory(ByVal arUniqueFormats As Variant, _
                                                ByVal sCategory As String) As Scripting.Dictionary
Dim lRowNo As Long
Dim icolno As Integer
Dim objFSOUniqueFormats As Scripting.Dictionary

   On Error GoTo AnError
   Set objFSOUniqueFormats = New Scripting.Dictionary
   
   icolno = 1
   For lRowNo = 0 To UBound(arUniqueFormats, 2)
      If (arUniqueFormats(0, lRowNo) = sCategory) Then
         If (objFSOUniqueFormats.Exists(arUniqueFormats(2, lRowNo)) = False) Then
            objFSOUniqueFormats.Add arUniqueFormats(2, lRowNo), icolno
            icolno = icolno + 1
         End If
      End If
   Next lRowNo
   
   Set ReturnUniqueFormatsForACategory = objFSOUniqueFormats
   Exit Function
AnError:
   MsgBox (Err.Number & " - " & Err.Description)
End Function
'**************************************************************************************
Public Function SortArray(ByVal arArray As Variant) As Variant

Dim Temp As Variant
Dim i As Long
Dim j As Long

ReDim Temp(4) As String

   On Error GoTo AnError
   
    For i = LBound(arArray, 2) To (UBound(arArray, 2) - 1)
        For j = (i + 1) To (UBound(arArray, 2))
        
            If arArray(4, i) > arArray(4, j) Then
            
                Temp(0) = arArray(0, j)
                Temp(1) = arArray(1, j)
                Temp(2) = arArray(2, j)
                Temp(3) = arArray(3, j)
                Temp(4) = arArray(4, j)
                
                arArray(0, j) = arArray(0, i)
                arArray(1, j) = arArray(1, i)
                arArray(2, j) = arArray(2, i)
                arArray(3, j) = arArray(3, i)
                arArray(4, j) = arArray(4, i)
                
                arArray(0, i) = Temp(0)
                arArray(1, i) = Temp(1)
                arArray(2, i) = Temp(2)
                arArray(3, i) = Temp(3)
                arArray(4, i) = Temp(4)
            End If
        Next j
    Next i
   SortArray = arArray
   
   Exit Function
AnError:
   MsgBox (Err.Number & " - " & Err.Description)
End Function
'**************************************************************************************
Public Function Col_Letter(ByVal icolno As Integer) As String
Dim inumber1 As Integer
On Error GoTo AnError
    Select Case icolno
       Case 0: Col_Letter = Chr(90)
      Case Is <= 26: Col_Letter = Chr(icolno + 64)
       Case Else
          inumber1 = Int((64 + ((icolno - 1) / 26)))
          Col_Letter = Chr(inumber1) & Chr(((icolno - 1) Mod 26) + 65)
    End Select
   Exit Function
AnError:
  Call MsgBox("Unable to return the corresponding letter for the column number " & _
              "'" & icolno & "'.")
End Function


© 2020 Better Solutions Limited. All Rights Reserved. © 2020 Better Solutions Limited TopPrevNext