Delete Unused Custom Formats
This procedure provides a workaround for the glaring lack of accessibility in VBA for manipulating custom number formats.
To do this, it hacks into the Number Format dialog box with SendKeys.
It loops through each item, including those custom number formats that have been orphaned from the worksheet.
The dialog box flickers upon each opening, but it works! If anyone comes up with a way to eliminate the flicker, let me know.
Sub DeleteUnusedCustomNumberFormats()
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 Dummy As Variant
Dim pPresent As Boolean
Dim NumberOfFormats As Long
Dim Answer
Dim c As Object
Dim DataStart As Long
Dim DataEnd As Long
Dim AnswerText As String
NumberOfFormats = 1000
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 ErrorHandler
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "CustomFormats"
Worksheets("CustomFormats").Activate
Set Buffer = Range("A2")
Buffer.Select
nFormat(0) = Buffer.NumberFormatLocal
Counter = 1
Do
SaveFormat = Buffer.NumberFormatLocal
Dummy = Buffer.NumberFormatLocal
DoEvents
SendKeys "{tab 3}{down}{enter}"
Application.Dialogs(xlDialogFormatNumber).Show Dummy
nFormat(Counter) = Buffer.NumberFormatLocal
Counter = Counter + 1
Loop Until nFormat(Counter - 1) = SaveFormat
ReDim Preserve nFormat(0 To Counter - 2)
Range("A1").Value = "Custom formats"
Range("B1").Value = "Formats used in workbook"
Range("C1").Value = "Formats not used"
Range("A1:C1").Font.Bold = True
StartRow = 3
EndRow = 16384
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 ActiveWorkbook.Worksheets
If Sh.Name = "CustomFormats" Then Exit For
For Each c In Sh.UsedRange.Cells
fFormat = c.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 c
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 c In Range(Cells(DataStart, 3), Cells(DataEnd, 3)).Cells
ActiveWorkbook.DeleteNumberFormat (c.NumberFormat)
Next c
End If
ErrorHandler:
Set c = Nothing
Set Sh = Nothing
Set Buffer = Nothing
End Sub
Public Sub ListAllFormats()
Dim iwshcount As Integer
Dim objWorksheet As Worksheet
Dim llastrow As Long
Dim ilastcolumn As Integer
Dim lRowNo As Long
Dim icolno As Integer
Dim arUniqueFormats2() As String
Dim objFSODictionary As Scripting.Dictionary
Dim objFSOUniqueTotals As Scripting.Dictionary
Dim objFSOWorksheetNames_Column As Scripting.Dictionary
Dim arUniqueWorksheetKeys As Variant
Dim snumberformat As String
Dim isheetandformatcount As Integer
Dim lcurrentrow As Long
Dim scellpattern As String
Dim scellstyle As String
Dim slastcolchar As String
On Error GoTo AnError
ReDim arUniqueFormats2(4, (3000 * ActiveWorkbook.Worksheets.Count)) As String
Set objFSODictionary = New Scripting.Dictionary
Set objFSOUniqueTotals = New Scripting.Dictionary
Set objFSOWorksheetNames_Column = New Scripting.Dictionary
For iwshcount = 1 To ActiveWorkbook.Worksheets.Count
Set objWorksheet = ActiveWorkbook.Worksheets(iwshcount)
If (objWorksheet.Name <> "Sheet1") Then
If (objWorksheet.Visible <> xlSheetVisible) Then
objWorksheet.Visible = xlSheetVisible
End If
If (objFSOWorksheetNames_Column.Exists(objWorksheet.Name) = False) Then
objFSOWorksheetNames_Column.Add objWorksheet.Name, iwshcount - 1
End If
objWorksheet.Select
llastrow = Range("A1").SpecialCells(XlCellType.xlCellTypeLastCell).Row
ilastcolumn = Range("A1").SpecialCells(XlCellType.xlCellTypeLastCell).Column
For lRowNo = 1 To llastrow
For icolno = 1 To ilastcolumn
snumberformat = Cells(lRowNo, icolno).NumberFormatLocal
Call UniqueFormatsPopulate("Number Format", snumberformat, lRowNo, icolno, objWorksheet.Name, _
objFSODictionary, objFSOUniqueTotals, arUniqueFormats2)
scellpattern = Cells(lRowNo, icolno).Interior.ColorIndex
Call UniqueFormatsPopulate("Shading Pattern", scellpattern, lRowNo, icolno, objWorksheet.Name, _
objFSODictionary, objFSOUniqueTotals, arUniqueFormats2)
scellstyle = Cells(lRowNo, icolno).Style
Call UniqueFormatsPopulate("Style", scellstyle, lRowNo, icolno, objWorksheet.Name, _
objFSODictionary, objFSOUniqueTotals, arUniqueFormats2)
Next icolno
Next lRowNo
End If
Next iwshcount
ReDim Preserve arUniqueFormats2(4, objFSOUniqueTotals.Count - 1)
arUniqueFormats2 = SortArray(arUniqueFormats2)
Worksheets("Sheet1").Select
Cells.Clear
Cells.ClearFormats
'display worksheets across the top
Range("C2").Value = "TOTAL"
arUniqueWorksheetKeys = objFSOWorksheetNames_Column.Keys()
For iwshcount = 0 To UBound(arUniqueWorksheetKeys, 1)
Cells(2, 4 + iwshcount).Value = arUniqueWorksheetKeys(iwshcount)
Next iwshcount
slastcolchar = Col_Letter(UBound(arUniqueWorksheetKeys, 1) + 4)
'display unique formats down left hand side - start by creating a list of unique formats
llastrow = 3
llastrow = PopulateTableWithCategory(slastcolchar, objFSODictionary, objFSOWorksheetNames_Column, arUniqueFormats2, "Number Format", llastrow)
llastrow = llastrow + 2
llastrow = PopulateTableWithCategory(slastcolchar, objFSODictionary, objFSOWorksheetNames_Column, arUniqueFormats2, "Shading Pattern", llastrow)
llastrow = llastrow + 2
llastrow = PopulateTableWithCategory(slastcolchar, objFSODictionary, objFSOWorksheetNames_Column, arUniqueFormats2, "Style", llastrow)
Exit Sub
AnError:
MsgBox (Err.Number & " - " & Err.Description)
End Sub
'**************************************************************************************
Public Sub UniqueFormatsPopulate(ByVal sCategoryName As String, _
ByVal sFormat As String, _
ByVal lRowNo As Long, _
ByVal icolno As Integer, _
ByVal sWshName As String, _
ByRef objFSODictionary As Scripting.Dictionary, _
ByRef objFSOUniqueTotals As Scripting.Dictionary, _
ByRef arUniqueFormats As Variant)
On Error GoTo AnError
If (objFSODictionary.Exists(sCategoryName & sWshName & "!!" & sFormat) = True) Then
objFSODictionary(sCategoryName & sWshName & "!!" & sFormat) = _
objFSODictionary(sCategoryName & sWshName & "!!" & sFormat) + 1
arUniqueFormats(3, objFSOUniqueTotals(sCategoryName & sWshName & "!!" & sFormat)) = _
arUniqueFormats(3, objFSOUniqueTotals(sCategoryName & sWshName & "!!" & sFormat)) & "-" & Cells(lRowNo, icolno).Address
Else
objFSODictionary.Add sCategoryName & sWshName & "!!" & sFormat, 1
objFSOUniqueTotals.Add sCategoryName & sWshName & "!!" & sFormat, (objFSOUniqueTotals.Count)
arUniqueFormats(0, objFSOUniqueTotals.Count - 1) = sCategoryName
arUniqueFormats(1, objFSOUniqueTotals.Count - 1) = sWshName
arUniqueFormats(2, objFSOUniqueTotals.Count - 1) = sFormat
arUniqueFormats(3, objFSOUniqueTotals.Count - 1) = Cells(lRowNo, icolno).Address
arUniqueFormats(4, objFSOUniqueTotals.Count - 1) = sCategoryName & sWshName & sFormat
End If
Exit Sub
AnError:
MsgBox (Err.Number & " - " & Err.Description)
End Sub
'**************************************************************************************
Public Function PopulateTableWithCategory(ByVal slastcolchar As String, _
ByVal objFSODictionary As Scripting.Dictionary, _
ByVal objFSOWorksheetNames_Column As Scripting.Dictionary, _
ByVal arUniqueFormats As Variant, _
ByVal sCategory As String, _
ByVal llastrow As Long) As Long
Dim objFSOUniqueFormats_Rows As Scripting.Dictionary
Dim arUniqueFormatKeys As Variant
Dim lRowNo As Long
On Error GoTo AnError
Set objFSOUniqueFormats_Rows = New Scripting.Dictionary
Set objFSOUniqueFormats_Rows = ReturnUniqueFormatsForACategory(arUniqueFormats, sCategory)
arUniqueFormatKeys = objFSOUniqueFormats_Rows.Keys
For lRowNo = 0 To UBound(arUniqueFormatKeys, 1)
Range("A" & lRowNo + llastrow).Value = sCategory
Range("B" & lRowNo + llastrow).Value = "''" & arUniqueFormatKeys(lRowNo)
Range("C" & lRowNo + llastrow).Value = "=SUM(D" & lRowNo + llastrow & ":" & _
slastcolchar & lRowNo + llastrow & ")"
If (sCategory = "Shading Pattern") Then
If (arUniqueFormatKeys(lRowNo) <> "-4142") Then
Range("B" & lRowNo + llastrow).Interior.ColorIndex = arUniqueFormatKeys(lRowNo)
End If
End If
Next lRowNo
Rows("2:2").Font.Bold = True
Columns("B:C").Font.Bold = True
'Columns("A").ColumnWidth = 3
Columns("A:B").EntireColumn.AutoFit
For lRowNo = 0 To UBound(arUniqueFormats, 2)
If (arUniqueFormats(0, lRowNo) = sCategory) Then
Cells((llastrow - 1) + objFSOUniqueFormats_Rows.Item(arUniqueFormats(2, lRowNo)), _
3 + objFSOWorksheetNames_Column.Item(arUniqueFormats(1, lRowNo))).Value = _
objFSODictionary(sCategory & arUniqueFormats(1, lRowNo) & "!!" & arUniqueFormats(2, lRowNo))
End If
Next lRowNo
PopulateTableWithCategory = llastrow + UBound(arUniqueFormatKeys, 1)
Exit Function
AnError:
MsgBox (Err.Number & " - " & Err.Description)
End Function
'**************************************************************************************
Public Function ReturnUniqueFormatsForACategory(ByVal arUniqueFormats As Variant, _
ByVal sCategory As String) As Scripting.Dictionary
Dim lRowNo As Long
Dim icolno As Integer
Dim objFSOUniqueFormats As Scripting.Dictionary
On Error GoTo AnError
Set objFSOUniqueFormats = New Scripting.Dictionary
icolno = 1
For lRowNo = 0 To UBound(arUniqueFormats, 2)
If (arUniqueFormats(0, lRowNo) = sCategory) Then
If (objFSOUniqueFormats.Exists(arUniqueFormats(2, lRowNo)) = False) Then
objFSOUniqueFormats.Add arUniqueFormats(2, lRowNo), icolno
icolno = icolno + 1
End If
End If
Next lRowNo
Set ReturnUniqueFormatsForACategory = objFSOUniqueFormats
Exit Function
AnError:
MsgBox (Err.Number & " - " & Err.Description)
End Function
'**************************************************************************************
Public Function SortArray(ByVal arArray As Variant) As Variant
Dim Temp As Variant
Dim i As Long
Dim j As Long
ReDim Temp(4) As String
On Error GoTo AnError
For i = LBound(arArray, 2) To (UBound(arArray, 2) - 1)
For j = (i + 1) To (UBound(arArray, 2))
If arArray(4, i) > arArray(4, j) Then
Temp(0) = arArray(0, j)
Temp(1) = arArray(1, j)
Temp(2) = arArray(2, j)
Temp(3) = arArray(3, j)
Temp(4) = arArray(4, j)
arArray(0, j) = arArray(0, i)
arArray(1, j) = arArray(1, i)
arArray(2, j) = arArray(2, i)
arArray(3, j) = arArray(3, i)
arArray(4, j) = arArray(4, i)
arArray(0, i) = Temp(0)
arArray(1, i) = Temp(1)
arArray(2, i) = Temp(2)
arArray(3, i) = Temp(3)
arArray(4, i) = Temp(4)
End If
Next j
Next i
SortArray = arArray
Exit Function
AnError:
MsgBox (Err.Number & " - " & Err.Description)
End Function
'**************************************************************************************
Public Function Col_Letter(ByVal icolno As Integer) As String
Dim inumber1 As Integer
On Error GoTo AnError
Select Case icolno
Case 0: Col_Letter = Chr(90)
Case Is <= 26: Col_Letter = Chr(icolno + 64)
Case Else
inumber1 = Int((64 + ((icolno - 1) / 26)))
Col_Letter = Chr(inumber1) & Chr(((icolno - 1) Mod 26) + 65)
End Select
Exit Function
AnError:
Call MsgBox("Unable to return the corresponding letter for the column number " & _
"'" & icolno & "'.")
End Function
Public Sub DeleteUnusedCustomNumberFormats() Dim aFormatsArray() As Variant Dim lRowLast_A As Long, lRowLast_B As Long, lRowLast_C As Long, lRowLast_D As Long Dim larraycount As Long, lCounter As Long, linside As Long, lrowno As Long, lTotalRemoved As Long Dim wsh As Excel.Worksheet Dim sFormat As String Dim cell As Excel.Range Dim bExists As Boolean
On Error GoTo ErrorHandler
If (AskForConfirmation = False) Then Exit Sub
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "CustomFormats"
Worksheets("CustomFormats").Activate
'------------------ formats available
aFormatsArray = GetListOfNumberFormats(Range("A2"), False)
For larraycount = 0 To UBound(aFormatsArray)
Worksheets("CustomFormats").Range("A" & larraycount + 2).Value = aFormatsArray(larraycount)
Next larraycount
lRowLast_A = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("A5000").End(XlDirection.xlUp).Address).Row
Worksheets("CustomFormats").Range("A2:A" & lRowLast_A).Sort _
Key1:=Worksheets("CustomFormats").Range("A2"), Order1:=xlAscending
'------------------ formats used
lCounter = 0
For Each wsh In ActiveWorkbook.Worksheets
If wsh.Name = "CustomFormats" Then Exit For
For Each cell In wsh.UsedRange.Cells
sFormat = cell.NumberFormatLocal
If Application.WorksheetFunction.CountIf(Worksheets("CustomFormats").Range("B:B"), sFormat) = 0 Then
Worksheets("CustomFormats").Range("B" & lCounter + 2).NumberFormatLocal = sFormat
Worksheets("CustomFormats").Range("B" & lCounter + 2).Value = sFormat
lCounter = lCounter + 1
End If
Next cell
Next wsh
lRowLast_B = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("B5000").End(XlDirection.xlUp).Address).Row
Worksheets("CustomFormats").Range("B2:B" & lRowLast_B).Sort _
Key1:=Worksheets("CustomFormats").Range("B2"), Order1:=xlAscending
'------------------ formats not used - those in red are not even valid formats
lRowLast_A = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("A5000").End(XlDirection.xlUp).Address).Row
lRowLast_B = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("B5000").End(XlDirection.xlUp).Address).Row
For lrowno = 2 To lRowLast_A
If (FormatIsFound(lRowLast_B, Worksheets("CustomFormats").Range("A" & lrowno).Value) = False) Then
Worksheets("CustomFormats").Range("C" & lCounter + 2).Value = _
Worksheets("CustomFormats").Range("A" & lrowno).Value
If (Worksheets("CustomFormats").Range("A" & lrowno).Value = 0) Then
Worksheets("CustomFormats").Range("C" & lCounter + 2).NumberFormatLocal = _
Worksheets("CustomFormats").Range("A" & lrowno).NumberFormatLocal
Else
If (ApplyNumberFormat(Worksheets("CustomFormats").Range("C" & lCounter + 2), _
Worksheets("CustomFormats").Range("A" & lrowno).Value) = False) Then
Worksheets("CustomFormats").Range("C" & lCounter + 2).Interior.Color = RGB(255, 91, 91)
End If
Worksheets("CustomFormats").Range("C" & lCounter + 2).NumberFormatLocal = "General"
End If
lCounter = lCounter + 1
End If
Next lrowno
lRowLast_C = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("C5000").End(XlDirection.xlUp).Address).Row
Worksheets("CustomFormats").Range("C2:C" & lRowLast_C).Sort _
Key1:=Worksheets("CustomFormats").Range("C2"), Order1:=xlAscending
'------------------ formats removed
lRowLast_C = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("C5000").End(XlDirection.xlUp).Address).Row
For lrowno = 2 To lRowLast_C
If (DeleteNumberFormat(Range("C" & lrowno).Value) = True) Then
Range("D" & lTotalRemoved + 2).Value = Range("C" & lrowno).Value
lTotalRemoved = lTotalRemoved + 1
Else
If (Range("C" & lrowno).Interior.Color <> RGB(255, 91, 91)) Then
Range("C" & lrowno).Interior.Color = RGB(146, 208, 80)
End If
End If
Next lrowno
lRowLast_D = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("D5000").End(XlDirection.xlUp).Address).Row
Worksheets("CustomFormats").Range("D2:D" & lRowLast_D).Sort _
Key1:=Worksheets("CustomFormats").Range("D2"), Order1:=xlAscending
Range("A1").Value = "Formats available"
Range("B1").Value = "Formats used"
Range("C1").Value = "Formats not used"
Range("D1").Value = "Formats removed"
Range("A1:D1").Font.Bold = True
Columns("A:D").ColumnWidth = 35
Columns("A:D").HorizontalAlignment = xlLeft
Range("A2").Select
ActiveWindow.FreezePanes = True
Call ConfirmRemoval(lTotalRemoved)
Set wsh = Nothing
Exit Sub
ErrorHandler:
Set wsh = Nothing
Call MsgBox(Err.Description)
End Sub
Private Function ApplyNumberFormat(ByVal oRange As Excel.Range, _
ByVal sNumberFormat As String) As Boolean
On Error GoTo ErrorHandler:
oRange.NumberFormatLocal = sNumberFormat
ApplyNumberFormat = True
Exit Function
ErrorHandler:
ApplyNumberFormat = False
End Function
Private Function FormatIsFound(ByVal lRowLast As Long, _
ByVal sNumberFormat As String) As Boolean Dim svalue As String
On Error GoTo ErrorHandler:
svalue = Application.WorksheetFunction.Match(sNumberFormat, _
Worksheets("CustomFormats").Range("B2:B" & lRowLast), 0)
FormatIsFound = True
Exit Function
ErrorHandler:
FormatIsFound = False
End Function
Private Function DeleteNumberFormat(ByVal sNumberFormat As String) As Boolean
On Error GoTo ErrorHandler:
Call ActiveWorkbook.DeleteNumberFormat(sNumberFormat)
DeleteNumberFormat = True
Exit Function
ErrorHandler:
DeleteNumberFormat = False
End Function
Private Function AskForConfirmation() As Boolean Dim iResult As VBA.VbMsgBoxResult
iResult = MsgBox("Do you want to delete unused custom formats from the workbook?", vbYesNo + vbQuestion)
If (iResult = vbNo) Then AskForConfirmation = False
If (iResult = vbYes) Then AskForConfirmation = True End Function
Private Sub ConfirmRemoval(ByVal lTotalRemoved As Long)
Call MsgBox( _
"'" & lTotalRemoved & "' number formats have been removed." & _
vbCrLf & vbCrLf & _
"The new 'CustomFormats' worksheet provides more information." & _
vbCrLf & vbCrLf & _
"The number formats that have been removed have been shaded in column 'C'.", _
vbInformation + vbOKOnly)
End Sub
Private Function GetListOfNumberFormats(ByVal oRange As Excel.Range, _
Optional ByVal bFromWorksheet As Boolean = False) As Variant Dim aFormatsArray() As Variant Dim sFormat As String, sSaveFormat As String Dim lCounter As Long, lRowLast As Long, lrowno As Long
On Error GoTo ErrorHandler:
ReDim aFormatsArray(0 To 2000)
If (bFromWorksheet = True) Then
lRowLast = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("A5000").End(XlDirection.xlUp).Address).Row
For lrowno = 2 To lRowLast
aFormatsArray(lrowno - 2) = Worksheets("CustomFormats").Range("A" & lrowno).Value
Next lrowno
lCounter = lrowno - 1
Else
oRange.Select
aFormatsArray(0) = oRange.NumberFormatLocal
lCounter = 1
Do
sSaveFormat = oRange.NumberFormatLocal
sFormat = oRange.NumberFormatLocal
VBA.DoEvents
SendKeys "{tab 3}{down}{enter}"
Application.Dialogs(xlDialogFormatNumber).Show sFormat
aFormatsArray(lCounter) = Range("A2").NumberFormatLocal
lCounter = lCounter + 1
Loop Until aFormatsArray(lCounter - 1) = sSaveFormat
End If
ReDim Preserve aFormatsArray(0 To lCounter - 2)
GetListOfNumberFormats = aFormatsArray
Exit Function
ErrorHandler:
Call MsgBox(Err.Message)
End Function
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrevNext