Question : Too Many Cell Formats

I'm starting to get the Too Many Cell Formats message again.  Is there any way to simplify the process of identifying gratuitous cell formats?   A free utility or anything of the sort?

Thanks,

John

Answer : Too Many Cell Formats

John,
Leo's macro worked for me in Excel 2003, but I did have to combine a number of lines that were split on the web page.

Sub DeleteUnusedCustomNumberFormats()
'[email protected], May 6. 2001
'Version 1.01
    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 pPresent As Boolean
    Dim NumberOfFormats As Long
    Dim Answer
    Dim Cell As Object
    Dim DataStart As Long
    Dim DataEnd As Long
    Dim AnswerText As String
    Dim ActWorkbookName As String
    Dim BufferWorkbookName As String

    NumberOfFormats = 1000
    StartRow = 3 ' Do not alter this value
    EndRow = 16384 ' For Excel 97 and 2000 set EndRow to 65536

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
    ActWorkbookName = ActiveWorkbook.Name
    Workbooks.Add
    BufferWorkbookName = ActiveWorkbook.Name

    Set Buffer = Workbooks(BufferWorkbookName).ActiveSheet.Range("A3")
    nFormat(0) = Buffer.NumberFormatLocal
    Buffer.NumberFormat = "@"
    Buffer.Value = nFormat(0)

    Workbooks(ActWorkbookName).Activate

    Counter = 1
    Do
        SaveFormat = Buffer.Value
        DoEvents
        SendKeys "{TAB 3}"
        For Counter1 = 1 To Counter
            SendKeys "{DOWN}"
        Next Counter1
        SendKeys "+{TAB}{HOME}'{HOME}+{END}^C{TAB 4}{ENTER}"
        Application.Dialogs(xlDialogFormatNumber).Show nFormat(0)
        ActiveSheet.Paste Destination:=Buffer
        Buffer.Value = Mid(Buffer.Value, 2)
        nFormat(Counter) = Buffer.Value
        Counter = Counter + 1
    Loop Until nFormat(Counter - 1) = SaveFormat

ReDim Preserve nFormat(0 To Counter - 2)

    Workbooks(BufferWorkbookName).Activate

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

    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 Workbooks(ActWorkbookName).Worksheets
        For Each Cell In Sh.UsedRange.Cells
            fFormat = Cell.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 Cell
    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 Cell In Range(Cells(DataStart, 3), Cells(DataEnd, 3)).Cells
            Workbooks(ActWorkbookName).DeleteNumberFormat (Cell.NumberFormat)
        Next Cell
    End If
Finito:
    Set Cell = Nothing
    Set Sh = Nothing
    Set Buffer = Nothing
End Sub

Brad