Sascotek,
I have attached some code which lists all Number Formats in the
ActiveWorkbook and also identifies those that are Used/Unused (by
Worksheets). However, I have to admit that I didn't write the code that
obtains all of the Number Formats in a Workbook. I found this elsewhere
and have used it as the base for a complex Number Format Tool that I
use.
Hopefully this will be of use.
Roger
Public Const NFTmbt As String = "Number Format Tool"
Public Const NFRn As String = "Number Format Report"
Private Const NFRbr1 As Integer = 1
Private Const NFRtr As Integer = 2
Private Const NFRbr2 As Integer = 3
Private Const NFRhr As Integer = 4
Private Const NFRbr3 As Integer = 5
Public Const NFRsr As Integer = 6
Private Const NFRbc1 As Integer = 1
Public Const NFRca As Integer = 2
Private Const NFRbc2 As Integer = 3
Public Const NFRcy As Integer = 4
Private Const NFRbc3 As Integer = 5
Public Const NFRcx As Integer = 6
Private Const NFRbc4 As Integer = 7
Private Const NFRaCI As Integer = 11
Private Const NFRyCI As Integer = 10
Private Const NFRxCI As Integer = 3
Sub NFR()
Application.ScreenUpdating = False
Let Start = Now()
Dim nF(0 To 10000) As Variant
Application.StatusBar = "Adding the '" & NFRn & "' Worksheet to: " &
ActiveWorkbook.Name
On Error Resume Next
Application.DisplayAlerts = False
Sheets(NFRn).Delete
Application.DisplayAlerts = True
Worksheets.Add Before:=Worksheets(1)
Worksheets(1).Name = NFRn
Worksheets(NFRn).Activate
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
Application.StatusBar = "Identifying all available formats in: " &
ActiveWorkbook.Name
On Error GoTo Failed
Set Buffer = Range("A1")
Buffer.Select
Let ii = 0
nF(ii) = Buffer.NumberFormatLocal
Let ii = 1
Do
SaveFormat = Buffer.NumberFormatLocal
Dummy = Buffer.NumberFormatLocal
DoEvents
SendKeys "{tab 3}{down}{enter}"
Application.Dialogs(xlDialogFormatNumber).Show Dummy
If Buffer.NumberFormatLocal = nF(ii - 1) Then GoTo
ExitIDLoop
nF(ii) = Buffer.NumberFormatLocal
Let ii = ii + 1
Loop Until nF(ii - 1) = SaveFormat
ExitIDLoop:
Application.StatusBar = "Creating the Number Format Report"
Cells(NFRtr, NFRca).Value = "Number Format Tool: Number Format
Report"
Cells(NFRhr, NFRca).Value = "All Formats"
Cells(NFRhr, NFRcy).Value = "Used Formats"
Cells(NFRhr, NFRcx).Value = "Unused Formats"
Application.StatusBar = "Creating the Number Format Report: Listing
All Formats"
Let ia = 0
Let iamax = ii - 1
For ia = 0 To iamax
Cells(NFRsr, NFRca).Offset(ia, 0).NumberFormatLocal = nF(ia)
Cells(NFRsr, NFRca).Offset(ia, 0).Value = nF(ia)
Next
Let NFRer = NFRsr + iamax
Let aFs = Range(Cells(NFRsr, NFRca), Cells(NFRer,
NFRca)).Address
Application.StatusBar = "Creating the Number Format Report: Listing
Used Formats"
Let iy = 0
Let yFs = Range(Cells(NFRsr, NFRcy), Cells(NFRer,
NFRcy)).Address
For Each w In ActiveWorkbook.Worksheets
Application.StatusBar = "Creating the Number Format Report:
Listing Used Formats on '" & w.Name & "'"
If w.Name <> NFRn Then
For Each c In w.UsedRange.Cells
Let cF = c.NumberFormatLocal
Let cFv = "~" & cF
If Application.WorksheetFunction.CountIf(Range(yFs),
cFv) = 0 Then
Cells(NFRsr, NFRcy).Offset(iy,
0).NumberFormatLocal = cF
Cells(NFRsr, NFRcy).Offset(iy, 0).Value = cFv
Let iy = iy + 1
End If
Cells(NFRbr3, NFRcy).Clear
Next c
End If
Next
Let iymax = iy - 1
Let yFs = Range(Cells(NFRsr, NFRcy), Cells(NFRsr + iymax,
NFRcy)).Address
For Each yF In Range(yFs)
yF.Value = Right(yF.Value, Len(yF.Value) - 1)
Next
Application.StatusBar = "Creating the Number Format Report: Listing
Unused Formats"
Let ix = 0
For Each aF In Range(aFs)
Let Usage = "Unused"
For Each yF In Range(yFs)
If yF.NumberFormatLocal = aF.NumberFormatLocal Then Let
Usage = "Used"
Next
If Usage = "Unused" Then
Cells(NFRsr, NFRcx).Offset(ix, 0).NumberFormatLocal =
aF.NumberFormatLocal
Cells(NFRsr, NFRcx).Offset(ix, 0).Value = aF.Value
ix = ix + 1
End If
Next
Let ixmax = ix - 1
Let xFs = Range(Cells(NFRsr, NFRcx), Cells(NFRsr + ixmax,
NFRcx)).Address
Application.StatusBar = "Formatting the Number Format Report"
With Range(Cells(NFRtr, NFRca), Cells(NFRtr, NFRcx))
.Font.Size = 12
.Font.ColorIndex = 11
.Font.Bold = True
.HorizontalAlignment = xlCenterAcrossSelection
End With
Cells(NFRhr, NFRca).Interior.ColorIndex = NFRaCI
Range(aFs).Font.ColorIndex = NFRaCI
Cells(NFRhr, NFRcy).Interior.ColorIndex = NFRyCI
Range(yFs).Font.ColorIndex = NFRyCI
Cells(NFRhr, NFRcx).Interior.ColorIndex = NFRxCI
Range(xFs).Font.ColorIndex = NFRxCI
Range(Cells(NFRhr, NFRca), Cells(NFRhr,
NFRcx)).SpecialCells(xlCellTypeConstants).Select
NFRfh
Range(Cells(NFRsr, NFRca), Cells(NFRer,
NFRcx)).SpecialCells(xlCellTypeConstants).Select
NFRff
Columns(NFRbc1).ColumnWidth = 4
Columns(NFRbc2).ColumnWidth = 2
Columns(NFRbc3).ColumnWidth = 2
Columns(NFRbc4).ColumnWidth = 4
Rows(NFRbr2).RowHeight = 5
Rows(NFRbr3).RowHeight = 5
Rows(NFRsr).Select
ActiveWindow.FreezePanes = True
Range(Cells(NFRhr, NFRbc1), Cells(NFRhr, NFRbc4)).Select
Selection.EntireColumn.Columns.AutoFit
ActiveWindow.Zoom = True
Cells(1, 1).Select
Application.StatusBar = False
Let Finish = Now
' MsgBox Format(((Finish - Start) * 86400), "#,##0.00 seconds"),
vbOKOnly + vbInFion, "Time Taken"
Exit Sub
Failed:
Let Line01 = "An Error has occured" & vbLf
Let Line02 = vbLf & "The " & NFRn & " has not been completed"
MsgBox Line01 & Line02, vbOKOnly + vbCritical, NFTmbt
Application.DisplayAlerts = False
Sheets(NFRn).Delete
Application.DisplayAlerts = True
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Sub NFRfh(Optional HideMacro As Bool
** Posted via:
http://www.ozgrid.com
Excel Templates, Training, Add-ins & Software!
http://www.ozgrid.com/Services/excel-software-categories.htm **