Help with Excel's DeleteNumberFormat macro

[rlee16]

I keep on getting a "cannot add anymore custom formats" in Excel as I have too many Custom Number formats (Format, Cells, Number, Custom). I would like to create a macro using vba that will hlep me delete all the custom numbers that I do not want. Thank you.

I asked a simliar question for Styles which Combo (a member of this community) answered. I am looking for something similar to erase the number formats.

Sub DeleteUserStyles()
On Error Resume Next
With ThisWorkbook
For I = .Styles.Count To 1 Step -1
If MsgBox("Delete " & .Styles(I).Name & "?", vbYesNo, "Confirm action&quot = vbYes Then
.Styles(I).Delete
End If
Next I
End With
End Sub

 

[xlhelp]

Here is a macro written by Leo Heuser:

I have not tested it.

Sub DeleteUnusedCustomNumberFormats()

' POWER PROGRAMMING TECHNIQUE

' By Leo Heuser

' 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.
'
' Added Note: The last worksheet in the spreadsheet must not be hidden or
' this procedure will not work.

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."
'Display Yes, No, and Cancel Buttons, No Button is Default
Answer = MsgBox(AnswerText, 259)
If Answer = vbCancel Then GoTo Finito

On Error Resume Next
'Add Workbook That Will Contain Formats
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "CustomFormats"
Worksheets("CustomFormats&quot.Activate
'Set First Element in Array nFormat to "General"
Set Buffer = Range("A2&quot
Buffer.Select
nFormat(0) = Buffer.NumberFormatLocal

'MAKE LIST OF CUSTOM FORMATS IN WORKBOOK
Counter = 1
Do
SaveFormat = Buffer.NumberFormatLocal
Dummy = Buffer.NumberFormatLocal
DoEvents
'Press These Keys After Displaying Dummy in the Custom Format List
SendKeys "{tab 3}{down}{enter}"
Application.Dialogs(xlDialogFormatNumber).Show Dummy
'Buffer is Now Reformatted to Next Format in List
nFormat(Counter) = Buffer.NumberFormatLocal
Counter = Counter + 1
'Continue Until No More Formats in List
'(Pressing "Down" Results in Same Format Being Selected)
Loop Until nFormat(Counter - 1) = SaveFormat

ReDim Preserve nFormat(0 To Counter - 2)

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

StartRow = 3
EndRow = 16384

'Format Cells to Preserve Display Format and Copy Format Values to Cells
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

'MAKE LIST OF FORMATS USED IN WORKBOOK
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 This Format Has Not Been Encountered Before, Format Cell
'to Preserve Display Format and Copy Format Value to Cell
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

'Find First Empty Cell in Column of Formats Used
xFormat = Range(Cells(StartRow, 2), Cells(EndRow, 2)).Find("&quot.Row - 2
'Counter2 Will Hold Number of Custom Formats Not Used in Workbook
Counter2 = 0
'FOR EACH FORMAT IN THE CUSTOM LIST
For Counter = 0 To UBound(nFormat)
pPresent = False
'See if Format From Custom List is in List of Formats Used
For Counter1 = 1 To xFormat
If nFormat(Counter) = Cells(StartRow, 2).Offset(Counter1,
0).NumberFormatLocal Then
pPresent = True
End If
Next Counter1
'If Custom Format was Not Used in Workbook, Format Cell
'to Preserve Display Format and Copy Format Value to Cell
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

'Format Spreadsheet Columns
With ActiveSheet.Columns("A:C&quot
.AutoFit
.HorizontalAlignment = xlLeft
End With

'To Delete Custom Formats Not Used in Workbook
If Answer = vbYes Then
'DataStart is Row of First Format Not Used in Workbook
'DataEnd is Row of Last Format Not Used in Workbook
DataStart = Range(Cells(1, 3), Cells(EndRow, 3)).Find("&quot.Row + 1
DataEnd = Cells(DataStart, 3).Resize(EndRow, 1).Find("&quot.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 In love with Irene Jacob. Wife knows about it, Irene doesn't.

 

[rlee16]

Thanks for the reply xlhelp! I have tested the code with mixed results, although I am sure it has more to do with the fact that I have just too many used formats. This program gets rid of all the unused ones, but not the ones currently in use. Ideally, I would be prompted about each one in use if I want to delete it. I'm afraid this is beyond my powers as this point to adjust the above code to do exactly what I want. Anyways, Thank you.