Excel VBA list all workbook custom number formats

I need to be able to list or cycle trough all custom number formats defined for a workbook (end goal: to delete them all).

Can someone tell me how to do this without cycling through every populated cell on every worksheet

In order to use <workbook>.DeleteNumberFormat you already need to know the number format - this I need to list them all.

I have see other forum postings & pages which seem to suggest they are looking for the same thing but all those i have so far found refer the questioner to a link with is no longer valid.

Any help would be much appreciated.
LVL 3
AL_XResearchAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

AL_XResearchAuthor Commented:
Better still would be a way to stop excel adding a cell's custom number format to it's 'memory' of custom formats !
Rgonzo1971Commented:
Hi,

pls refer to
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Q_20310890.html
to create a list of standard and custom 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

Open in new window

Regards
AL_XResearchAuthor Commented:
Rgonzo1971: Thank you for the quick response but I have already seen that post and it cycles through all cells to find different custom number formats and as is said in my initial post this is what I am trying to avoid.

As I also said I am aware of 'DeleteNumberFormat' but to use this you need to know the number format string to delete - a catch 22.

Also note that if you use 'DeleteNumberFormat' after you add a custom numberformat to a cell the cell loses the format you just added. So that is no use.
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Rgonzo1971Commented:
HI,

it cycles through the cells to delete the unused formats but if you could use the Format list to delete the formats without testing whether they are used or not
AL_XResearchAuthor Commented:
How would you use the 'format list'  ? You mean manually via the front-end ?
Rgonzo1971Commented:
pls try

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

Open in new window

AL_XResearchAuthor Commented:
Rgonzo1971: Thanks for the example. This however is sing SendKeys to simulate user interaction and this is generally bad practice, time consuming and shows a flashing screen to the user.

I think the answer is: there is no way to do this via VBA.

I will just have to use 1 custom number format for all cells and then only one custom number format will be added to the format dialog and stored against the workbook

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
AL_XResearchAuthor Commented:
What I am looking for appears impossible and the only way to do this is as I have suggested in my last post
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.