How can i create a macro that will delete any un used
custom format?

I will really appreciate your assistance.

Tom

Hi Tom,

See the routine posted by Leo Heuser:

http://tinyurl.com/5c4bs



---
Regards,
Norman



"Tom" wrote in message
...
How can i create a macro that will delete any un used
custom format?

I will really appreciate your assistance.

Tom

Hi Tom,

The routine foe which I provided a link is, in fact, designed to remove
unused styles.

The routine by Leo for which I had intended to provide a link is:


---------------------------- START
Sub DeleteUnusedCustomNumberFormats()
, 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 = 16384 ' For Excel 97 and 2000 set EndRow to 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("A 3")
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

---------------------------- END

---
Regards,
Norman



"Tom" wrote in message
...
How can i create a macro that will delete any un used
custom format?

I will really appreciate your assistance.

Tom

Thanks Norman!
-----Original Message-----
Hi Tom,

The routine foe which I provided a link is, in fact,
designed to remove
unused styles.

The routine by Leo for which I had intended to provide a
link is:


---------------------------- START
Sub DeleteUnusedCustomNumberFormats()
, 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 = 16384 ' For Excel 97 and 2000 set EndRow to
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

---------------------------- END

---
Regards,
Norman



"Tom" wrote in
message
...
How can i create a macro that will delete any un used
custom format?

I will really appreciate your assistance.

Tom


.