I want to know how many unique formats are present in an excel workbook. My
excel workbook is getting corrupted when I add more worksheets. I want to
check how many unique formats are there in my workbook so that I can stop
adding worksheets if the limit exceeds.

Perhaps Look at the last entry he

http://www.j-walk.com/ss/excel/eee/eee015.txt

--
Regards,
Tom Ogilvy


"Deepa" wrote in message
...
I want to know how many unique formats are present in an excel workbook.
My
excel workbook is getting corrupted when I add more worksheets. I want to
check how many unique formats are there in my workbook so that I can stop
adding worksheets if the limit exceeds.

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:D").ColumnWidth = 6
.Columns("B:D").HorizontalAlignment = xlCenter
.Columns("B:D").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 :

I want to know how many unique formats are present in an excel
workbook. My excel workbook is getting corrupted when I add more
worksheets. I want to check how many unique formats are there in my
workbook so that I can stop adding worksheets if the limit exceeds.