Too Many Different Cell Formats [closed]
The problem you describe caused me (and a coworker) to lose many hours of productivity when using Excel 2010. The following VBA code / macro helped me to drop a .xlsm file from using 3540 styles down to 34.
' Description:' Borrowed largely from http://www.jkp-ads.com/Articles/styles06.aspOption Explicit' Description:' This is the "driver" for the entire module.Public Sub DropUnusedStyles() Dim styleObj As Style Dim rngCell As Range Dim wb As Workbook Dim wsh As Worksheet Dim str As String Dim iStyleCount As Long Dim dict As New Scripting.Dictionary ' <- from Tools / References... / "Microsoft Scripting Runtime" ' wb := workbook of interest. Choose one of the following ' Set wb = ThisWorkbook ' choose this module's workbook Set wb = ActiveWorkbook ' the active workbook in excel Debug.Print "BEGINNING # of styles in workbook: " & wb.Styles.Count MsgBox "BEGINNING # of styles in workbook: " & wb.Styles.Count ' dict := list of styles For Each styleObj In wb.Styles str = styleObj.NameLocal iStyleCount = iStyleCount + 1 Call dict.Add(str, 0) ' First time: adds keys Next styleObj Debug.Print " dictionary now has " & dict.Count & " entries." ' Status, dictionary has styles (key) which are known to workbook ' Traverse each visible worksheet and increment count each style occurrence For Each wsh In wb.Worksheets If wsh.Visible Then For Each rngCell In wsh.UsedRange.Cells str = rngCell.Style dict.Item(str) = dict.Item(str) + 1 ' This time: counts occurrences Next rngCell End If Next wsh ' Status, dictionary styles (key) has cell occurrence count (item) ' Try to delete unused styles Dim aKey As Variant On Error Resume Next ' wb.Styles(aKey).Delete may throw error For Each aKey In dict.Keys ' display count & stylename ' e.g. "24 Normal" Debug.Print dict.Item(aKey) & vbTab & aKey If dict.Item(aKey) = 0 Then ' Occurrence count (Item) indicates this style is not used Call wb.Styles(aKey).Delete If Err.Number <> 0 Then Debug.Print vbTab & "^-- failed to delete" Err.Clear End If Call dict.Remove(aKey) End If Next aKey Debug.Print "ENDING # of style in workbook: " & wb.Styles.Count MsgBox "ENDING # of style in workbook: " & wb.Styles.CountEnd Sub
"Cell formats" are complicated. Cells do not really have a "format". They have a font (which itself has a name and a size), a NumberFormat, Height, Width, Orientation, etc.
So you need to define what you mean by "format".
Below is code to get the Font Name and Size. You can substitute whatever attributes you like.
The code below assumes you have created a Worksheet named "Formats" in the workbook. After you run the macro, the Font Names and sizes will be listed in that worksheet.
Public Sub GetFormats() Dim CurrentSheet As Integer Dim UsedRange As Range Dim CurrentCell As Range Dim rw As Long Sheets("Formats").Cells.ClearContents rw = 1 For CurrentSheet = 1 To Sheets.Count Set UsedRange = Range(Sheets(CurrentSheet).Range("A1"), Sheets(CurrentSheet).Range("A1").SpecialCells(xlLastCell)) For Each CurrentCell In UsedRange FontUsed = CurrentCell.Font.Name + ":" + CStr(CurrentCell.Font.Size) If Sheets("Formats").Cells.Find(FontUsed) Is Nothing Then Sheets("Formats").Cells(rw, 1).Value = FontUsed rw = rw + 1 End If Next Next CurrentSheetEnd Sub
Lots of people seem to run into this problem.
Most often the issue is related to the excessive number of unused and often corrupted styles and not so much the total count of the cell unique cell format combos.
I wrote a utility to fix XL2007 OOXML files that can be saved down to XL2003. Here is the link to the blog post:
- Requires .Net3.5 and MS Excel 2007.
- Will fix xlsx or xlsm files.
- The post has a ReadMe file to go with the app.
No need to run the risk of further corrupting your file by using Open Office like it is suggested on some other forums