dump following code in a module & run it.
it was inspired by some code from LeoHeuser and reworked by me.
a different approach from the code at Walker's site.
Option Explicit
Option Base 0
'USER32
Private Declare Function GetDesktopWindow Lib "user32" ( _
) As Long
Private Declare Function LockWindowUpdate Lib "user32" ( _
ByVal hwndLock As Long) As Long
Sub ClearUnusedNumberFormats()
Dim cUsed As Collection
Dim cDefi As Collection
Dim cKill As Collection
Dim cSyst As Collection
Dim cCust As Collection
Dim vItm As Variant
Dim sMsg As String
Dim i%, v
Set cDefi = DefinedNumberFormats
Set cUsed = UsedNumberFormats
Set cKill = New Collection
Set cSyst = New Collection
Set cCust = New Collection
On Error Resume Next
Application.ScreenUpdating = False
For Each vItm In cDefi
If IsError(cUsed(vItm(1))) Then
Err.Clear
ActiveWorkbook.DeleteNumberFormat vItm(0)
If Err = 0 Then cKill.Add vItm, _
vItm(1) Else cSyst.Add vItm, vItm(1)
End If
Next
Application.ScreenUpdating = True
sMsg = sMsg & "Total " & vbTab & "Defined" & vbTab & _
Format(cDefi.Count, "##0") & vbNewLine
sMsg = sMsg & "Custom " & vbTab & "Removed" & vbTab & _
Format(cKill.Count, "##0") & String(2, vbNewLine)
sMsg = sMsg & "Custom " & vbTab & "Used " & vbTab & _
Format(cUsed.Count, "##0") & vbNewLine
sMsg = sMsg & "BuiltIn" & vbTab & "Unused " & vbTab & _
Format(cSyst.Count, "##0") & vbNewLine
sMsg = sMsg & " " & vbTab & " " & vbTab & _
"---" & vbNewLine
sMsg = sMsg & "Remain " & vbTab & "Defined" & vbTab & _
Format(cSyst.Count + cUsed.Count, "##0") & vbNewLine
sMsg = sMsg & vbNewLine & "Do you want a report?"
If vbYes = MsgBox(sMsg, vbQuestion + vbYesNo, _
"NumberFormatCleaner") Then
With Workbooks.Add(xlWBATWorksheet).Worksheets(1).Cells( _
1)
ActiveWindow.DisplayGridlines = False
With .Resize(, 4)
.Value = Array("NumberFormat", "Removed", "Used", _
"System")
With .Font
.Size = .Size * 1.2
.Bold = True
End With
End With
With .Offset(1, 1).Resize(cDefi.Count, 3)
.Font.Name = "Wingdings"
.Font.Size = .Font.Size * 1.2
End With
For Each vItm In cDefi
i = i + 1
.Offset(i, 0).Resize(, 4).NumberFormat = "@"
.Offset(i, 0) = vItm(1)
Err.Clear: v = cKill(vItm(1))
If Err = 0 Then .Offset(i, 1) = "û"
Err.Clear: v = cUsed(vItm(1))
If Err = 0 Then .Offset(i, 2) = "ü"
Err.Clear: v = cSyst(vItm(1))
If Err = 0 Then .Offset(i, 3) = "ü"
Next
With .CurrentRegion
.Sort Key1:=.Columns(4), Order1:=xlDescending, _
Key2:=.Columns(3), Order2:=xlDescending, _
Key3:=.Columns(2), Order3:=xlDescending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
.Offset(1).VerticalAlignment = xlCenter
.Columns("A").EntireColumn.AutoFit
.Columns("B
").ColumnWidth = 6
.Columns("B
").HorizontalAlignment = xlCenter
.Columns("B
").Rows(1).Orientation = 45
With .Columns("A:E").Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
End With
End With
End If
End Sub
Function UsedNumberFormats( _
Optional wkb As Workbook) As Collection
Dim cRes As Collection
Dim wks As Worksheet
Dim rng As Range
Dim sGen As String
Dim win(0 To 2) As Long
Dim r&, c%
With Application
win(2) = .DisplayStatusBar
.DisplayStatusBar = True
sGen = .International(xlGeneralFormatName)
End With
If wkb Is Nothing Then Set wkb = ActiveWorkbook
Set cRes = New Collection
On Error Resume Next
For Each wks In wkb.Worksheets
With wks.UsedRange
For c = 0 To .Columns.Count - 1
Application.StatusBar = _
"retrieving used numberformats from " & .Columns( _
c + 1).Address(external:=True)
If IsNull(.Columns(c + 1).NumberFormatLocal) Then
Set rng = .Cells(1)
For r = 0 To .Rows.Count - 1
With rng.Offset(r, c)
If .NumberFormatLocal <> sGen Then
cRes.Add Array(.NumberFormat, _
.NumberFormatLocal), .NumberFormatLocal
End If
End With
Next
ElseIf .Columns( _
c + 1).NumberFormatLocal <> sGen Then
cRes.Add Array(.Columns(c + 1).NumberFormat, _
.Columns(c + 1).NumberFormatLocal), _
.Columns(c + 1).NumberFormatLocal
End If
Next
End With
Next
Set UsedNumberFormats = cRes
With Application
.StatusBar = False
.DisplayStatusBar = win(2)
sGen = .International(xlGeneralFormatName)
End With
End Function
Function DefinedNumberFormats( _
Optional wkb As Workbook) As Collection
'Reworked from Leo Heusers original approach
Dim cRes As Collection
Dim rng(0 To 1) As Range
Dim win(0 To 2) As Long
Dim sGen As String
Set cRes = New Collection
sGen = Application.International(xlGeneralFormatName)
If wkb Is Nothing Then Set wkb = ActiveWorkbook Else _
wkb.Activate
'Find a blank cell with General numberformat
With ActiveSheet.Cells
Set rng(0) = ActiveCell
Set rng(1) = .Find("", rng(0))
If rng(1) Is Nothing Then Set rng(1) = rng(0)
While rng(0).Address <> rng(1).Address And rng( _
1).NumberFormatLocal <> sGen
Set rng(1) = .FindNext(rng(1))
Wend
End With
If rng(1).NumberFormatLocal <> sGen Then Exit Function
With Application
win(2) = .DisplayStatusBar
.DisplayStatusBar = True
.StatusBar = "retrieving defined numberformats..."
LockWindowUpdate GetDesktopWindow
win(0) = .WindowState
.WindowState = xlNormal
win(1) = .Top
.Top = .Top - 5000
End With
rng(1).Select
'Loop Thru the Dialog
cRes.Add Array(rng(1).NumberFormat, _
rng(1).NumberFormatLocal), rng(1).NumberFormatLocal
On Error GoTo done
Do
DoEvents
SendKeys "{tab 3}{down}{enter}"
Application.Dialogs(xlDialogFormatNumber).Show cRes( _
cRes.Count)(1)
cRes.Add Array(rng(1).NumberFormat, _
rng(1).NumberFormatLocal), rng(1).NumberFormatLocal
Loop
done:
rng(1).NumberFormat = "General"
Set DefinedNumberFormats = cRes
With Application
.StatusBar = False
.DisplayStatusBar = win(2)
.Top = win(1)
.WindowState = win(0)
End With
LockWindowUpdate False
End Function
--
keepITcool
|
www.XLsupport.com | keepITcool chello nl | amsterdam
Deepa wrote :
