Excel VBA list all workbook custom number formats

Sub DeleteUnusedCustomNumberFormats()
 'leo.heuser@get2net.dk May 1999
 'For Windows only
 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

Select allOpen in new window

Sub Macro()
Dim nFormat() As Variant
Dim SaveFormat As Variant
Dim Counter  As Long

 
NumberOfFormats = 1000
Set Buffer = Range("A1")
Buffer.Select

ReDim nFormat(0 To NumberOfFormats)
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)
For Each Item In nFormat
    On Error Resume Next
    ActiveWorkbook.DeleteNumberFormat Item
    On Error GoTo 0
Next Item
End Sub

Select allOpen in new window