Too many different format

gquest

Board Regular
Joined
Feb 20, 2007
Messages
167
My boss has a spread sheet that is an absolute mess. He's copied and pasted tabs from a bunch of different workbooks and now when he tries to format a cell he gets an error message saying "Too many different formats".

I've been searching on this board and on Google for a macro to fix the issue, but the only one I found doesn't seem to fix the issue (see below). It's only for Custom formats.

I think there are duplicate formats from all the copying and pasting he's been doing, but that's just a guess. I also read the information on this on Microsoft's webpage about using a standard text, borders, etc. The only thing I can think of is to copy paste formulas everything into a new workbook and then format everything again by hand, but that could take a while given how many tabs there are.

Has anyone found a solution for this (preferably a VBA one) or any suggestions on how I can fix this issue?


Thank you in advance for your help!

George

Code:
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 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
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
This is one instance where the error message and solution in Excel is explicit.

We are only allowed a certain number of different cell formats (depending on what version you are using).

A cell format includes anything on the list that we get with menu Format/Cells. eg. font name, font size, number format, borders ..etc. A single cell with a single difference can use up one of our allowance. So you have a reformatting job .... Edit/Copy then Paste Formats wherever possible. Even empty cells contain some sort of formatting.

For example, if numerous fonts (names) are being used you could select the whole sheet and change everything to a single font. That would reduce the number of variances straight away. Similar with font sizes.

Although it may not be entirely relevant here, take the time to select all the "empty" rows at the bottom of the sheet and delete them. Same with columns to the right. If they have been used earlier for something Excel will "remember". This often reduces file size considerably. They could contain some odd formats, which will be converted to the default.
 
Upvote 0

Forum statistics

Threads
1,213,494
Messages
6,113,986
Members
448,538
Latest member
alex78

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top