Remove Unused Number Formats in Excel (VBA)

RemoveUnusedNumberFormats.bas

Sub RemoveUnusedNumberFormats()
  Dim strOldFormat As String
  Dim strNewFormat As String
  Dim aCell As Range
  Dim sht As Worksheet
  Dim strFormats() As String
  Dim fFormatsUsed() As Boolean
  Dim i As Integer

  If ActiveWorkbook.Worksheets.Count = 0 Then
    MsgBox "The active workbook doesn't contain any worksheets.", vbInformation
    Exit Sub
  End If

  On Error GoTo Exit_Sub
  Application.Cursor = xlWait
  ReDim strFormats(1000)
  ReDim fFormatsUsed(1000)
  Set aCell = Range("A1")
  aCell.Select
  strOldFormat = aCell.NumberFormatLocal
  aCell.NumberFormat = "General"
  strFormats(0) = "General"
  strNewFormat = aCell.NumberFormatLocal
  i = 1
  Do
    ' Dialog requires local format
    SendKeys "{TAB 3}{DOWN}{ENTER}"
    Application.Dialogs(xlDialogFormatNumber).Show strNewFormat
    strFormats(i) = aCell.NumberFormat
    strNewFormat = aCell.NumberFormatLocal
    i = i + 1
  Loop Until strFormats(i - 1) = strFormats(i - 2)
  aCell.NumberFormatLocal = strOldFormat
  ReDim Preserve strFormats(i - 2)
  ReDim Preserve fFormatsUsed(i - 2)
  For Each sht In ActiveWorkbook.Worksheets
    For Each aCell In sht.UsedRange
      For i = 0 To UBound(strFormats)
        If aCell.NumberFormat = strFormats(i) Then
          fFormatsUsed(i) = True
          Exit For
        End If
      Next i
    Next aCell
  Next sht
  ' Suppress errors for built-in formats
  On Error Resume Next
  For i = 0 To UBound(strFormats)
    If Not fFormatsUsed(i) Then
      ' DeleteNumberFormat requires international format
      ActiveWorkbook.DeleteNumberFormat strFormats(i)
    End If
  Next i

Exit_Sub:
  Set aCell = Nothing
  Set sht = Nothing
  Erase strFormats
  Erase fFormatsUsed
  Application.Cursor = xlDefault
End Sub

Originally from http://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-mso_other/delete-custom-formats/23d6727c-d052-e011-8dfc-68b599b31bf5

Thanks, this is great