Sub DeleteUnusedCustomNumberFormats()
'leo.heuser...@get2net.dk, 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 = 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
