Macro to edit styles.xml file of workbook

[Gimics]

Hey pro-team!

Our company has a problem with copying and pasting data dumps from our ERP system into workbooks over-and-over, resulting in compounding workbook styles to the point where multiple workbooks each month hit the excel style count max (~64,000), which causes workbook crashing and an inability to use these worksheets until the styles are fixed.

I've done a decent amount of research to try to discover the best way to fix these files. I've tried these things:

1. Macro that loops through styles and deletes the unused styles - takes a long time in a workbook with 30+ tabs and 64,000 styles
2. Macro that loops through styles and deletes the non-built in styles - takes at least 15 minutes in any size workbook with 64,000 styles
3. Editing the styles.xml file manually to delete the styles - with 64,000 styles, it's nearly impossible to delete all styles but the built-in styles. If all of the styles are deleted, the entire workbook loses all of it's formatting.

I am hoping someone can help me with building a macro to open and edit the styles.xml file to remove all of the relevant style records associated with styles that are not the built in styles. I think I know enough to walk through this with the manual approach, but don't know enough vba to automate.

The first step would be to get at the styles.xml file for the excel spreadsheet. The manual method I've seen for doing this is to manually change the extension of the excel file from .xls? to .zip, and then the styles.xml file is saved in the /xl directory. Example: "\Book1.zip\xl\styles.xml"

I think the seconds step is to then create an array or several arrays with the relevant cell style sections in the xml file. Based on my research and testing, there are three relevant sections of the xml (this a valuable reference: https://wiki.openoffice.org/wiki/Cell_Style_in_Xls_module)

<cellstylexfs ...=""> has the master formatting records. It has zero-based "xf" records indexed and referenced later using "xfID="N"" tags.
<cellxfs ...=""> has the master formatting "xf" records that are first applied and reference the cellstylexfs indexed records using "xfID="N" tags.
<cellstyles ...=""> has the named style "cellStyle" records and reference the cellstylexfs index records using "xfID="N" tags. Built in Styles are also indexed and labelled with builtinId="30" tags.

I created a test workbook with 10 cell styles applied, five of which are built in and five of which are not built in. These are the relevant xml sections that I think need to be edited
(my apologies for the terrible formatting - I couldn't wrap the xml code in anything without it disappearing entirely):
<cellStyleXfs count="11">
<xf numFmtId="0" fontId="0" fillId="0" borderId="0" />
<xf numFmtId="0" fontId="2" fillId="2" borderId="0" applyNumberFormat="0" applyBorder="0" applyAlignment="0" applyProtection="0" />
<xf numFmtId="0" fontId="3" fillId="3" borderId="0" applyNumberFormat="0" applyBorder="0" applyAlignment="0" applyProtection="0" />
<xf numFmtId="0" fontId="4" fillId="4" borderId="0" applyNumberFormat="0" applyBorder="0" applyAlignment="0" applyProtection="0" />
<xf numFmtId="0" fontId="1" fillId="5" borderId="0" applyNumberFormat="0" applyBorder="0" applyAlignment="0" applyProtection="0" />
<xf numFmtId="0" fontId="1" fillId="6" borderId="0" applyNumberFormat="0" applyBorder="0" applyAlignment="0" applyProtection="0" />
<xf numFmtId="0" fontId="6" fillId="7" borderId="1" />
<xf numFmtId="0" fontId="5" fillId="8" borderId="0" />
<xf numFmtId="0" fontId="7" fillId="9" borderId="1" />
<xf numFmtId="0" fontId="8" fillId="10" borderId="0" />
<xf numFmtId="0" fontId="9" fillId="11" borderId="0" />
</cellStyleXfs>

<cellXfs count="11">
<xf numFmtId="0" fontId="0" fillId="0" borderId="0" xfId="0" />
<xf numFmtId="0" fontId="3" fillId="3" borderId="0" xfId="2" />
<xf numFmtId="0" fontId="2" fillId="2" borderId="0" xfId="1" />
<xf numFmtId="0" fontId="4" fillId="4" borderId="0" xfId="3" />
<xf numFmtId="0" fontId="1" fillId="5" borderId="0" xfId="4" />
<xf numFmtId="0" fontId="1" fillId="6" borderId="0" xfId="5" />
<xf numFmtId="0" fontId="6" fillId="7" borderId="1" xfId="6" />
<xf numFmtId="0" fontId="5" fillId="8" borderId="0" xfId="7" />
<xf numFmtId="0" fontId="7" fillId="9" borderId="1" xfId="8" />
<xf numFmtId="0" fontId="8" fillId="10" borderId="0" xfId="9" />
<xf numFmtId="0" fontId="9" fillId="11" borderId="0" xfId="10" />
</cellXfs>

<cellStyles count="11">
<cellStyle name="20% - Accent1" xfId="4" builtinId="30" />
<cellStyle name="20% - Accent2" xfId="5" builtinId="34" />
<cellStyle name="Bad" xfId="2" builtinId="27" />
<cellStyle name="Good" xfId="1" builtinId="26" />
<cellStyle name="Neutral" xfId="3" builtinId="28" />
<cellStyle name="Normal" xfId="0" builtinId="0" />
<cellStyle name="Style 1" xfId="6" />
<cellStyle name="Style 2" xfId="7" />
<cellStyle name="Style 3" xfId="8" />
<cellStyle name="Style 4" xfId="9" />
<cellStyle name="Style 5" xfId="10" />
</cellStyles>


I think the macro would need to identify the indexes (xfID values) for all of the styles with "buildinId" tags, and then delete all of the records in all three sections for styles that are not built in. After the macro runs, I think these sections should look like this:
<cellStyleXfs count="11">
<xf numFmtId="0" fontId="0" fillId="0" borderId="0" />
<xf numFmtId="0" fontId="2" fillId="2" borderId="0" applyNumberFormat="0" applyBorder="0" applyAlignment="0" applyProtection="0" />
<xf numFmtId="0" fontId="3" fillId="3" borderId="0" applyNumberFormat="0" applyBorder="0" applyAlignment="0" applyProtection="0" />
<xf numFmtId="0" fontId="4" fillId="4" borderId="0" applyNumberFormat="0" applyBorder="0" applyAlignment="0" applyProtection="0" />
<xf numFmtId="0" fontId="1" fillId="5" borderId="0" applyNumberFormat="0" applyBorder="0" applyAlignment="0" applyProtection="0" />
<xf numFmtId="0" fontId="1" fillId="6" borderId="0" applyNumberFormat="0" applyBorder="0" applyAlignment="0" applyProtection="0" />
</cellStyleXfs>

<cellXfs count="11">
<xf numFmtId="0" fontId="0" fillId="0" borderId="0" xfId="0" />
<xf numFmtId="0" fontId="3" fillId="3" borderId="0" xfId="2" />
<xf numFmtId="0" fontId="2" fillId="2" borderId="0" xfId="1" />
<xf numFmtId="0" fontId="4" fillId="4" borderId="0" xfId="3" />
<xf numFmtId="0" fontId="1" fillId="5" borderId="0" xfId="4" />
<xf numFmtId="0" fontId="1" fillId="6" borderId="0" xfId="5" />
</cellXfs>

<cellStyles count="11">
<cellStyle name="20% - Accent1" xfId="4" builtinId="30" />
<cellStyle name="20% - Accent2" xfId="5" builtinId="34" />
<cellStyle name="Bad" xfId="2" builtinId="27" />
<cellStyle name="Good" xfId="1" builtinId="26" />
<cellStyle name="Neutral" xfId="3" builtinId="28" />
<cellStyle name="Normal" xfId="0" builtinId="0" />
</cellStyles>


Might be a crazy big ask, but I really can't find anything else out there that get's this detailed on this problem (I've found a lot of posts with common problems, and a few posts with partial or manual solutions).

Thanks in advance!</cellstyles></cellxfs></cellstylexfs>

 

[ZVI]

My misprint in #9: avarData = Replace(avarData, ")", "<")
Should be: avarData = Replace(avarData, ")", ">")

 

[Gimics]

Try using vbTextCompare instead of vbBinaryCompare just for the case

That worked! Now lstart and lstop are being populated with numbers and the macro completes. The workbook behaves a bit strange the first time you open it - there are error messages about missing styles, but it only went through a few and after saving, it didn't happen again.

I updated the code to be a bit more dynamic so that the workbook with the macro doesn't need to be in the same location as the workbook being fixed.

Here's my end result:

Const csSTYLES_START As String = "<" & "cellstyles"Const csSTYLES_CLOSE As String = "<" & "/cellstyles" & ">"
Const csDEFAULT_STYLES As String = csSTYLES_START & " count=""1""" & ">" _
    & "<" & "cellStyle name=""Normal"" xfId=""0"" builtinId=""0"" customBuiltin=""1"" /" & ">" _
    & csSTYLES_CLOSE


Option Explicit


Sub DeleteStyles()
Dim R As Long, PathFilename As Variant, FileNameInZip As Variant, oApp As Object, ZipFileName As Variant
Dim wbSelect As Workbook
Dim lFile As Long
Dim sStylePath As String
Dim avarData As String
Dim fso As Object, tsrStream1 As Object
Dim lStart As Long, lStop As Long
  
  PathFilename = Application.GetOpenFilename("Excel XML files (*.xls?), *.xls?")
  If PathFilename = "False" Then Exit Sub
    
  sStylePath = Left$(PathFilename, InStrRev(PathFilename, "\")) & "styles.xml"
  If Dir(sStylePath) <> vbNullString Then Kill sStylePath
  
  ZipFileName = Left$(PathFilename, InStrRev(PathFilename, ".")) & "zip"
  If Dir(ZipFileName) <> vbNullString Then Kill ZipFileName
  
  FileCopy PathFilename, ZipFileName
  
  Set oApp = CreateObject("Shell.Application")
  oApp.Namespace(Left$(PathFilename, InStrRev(PathFilename, "\"))).CopyHere oApp.Namespace(ZipFileName & "\xl").Items.Item("styles.xml")
    Do Until Dir(sStylePath) <> vbNullString
        DoEvents
    Loop
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set tsrStream1 = fso.OpenTextFile(sStylePath, 1, False)
    avarData = tsrStream1.ReadAll
    tsrStream1.Close
    lStart = InStr(1, avarData, csSTYLES_START, vbTextCompare)
    lStop = InStr(1, avarData, csSTYLES_CLOSE, vbTextCompare)
    avarData = Left$(avarData, lStart - 1) & csDEFAULT_STYLES & Mid$(avarData, lStop + Len(csSTYLES_CLOSE))
    Set tsrStream1 = fso.CreateTextFile(sStylePath, True)
    tsrStream1.Write avarData
    tsrStream1.Close
    oApp.Namespace(ZipFileName & "\xl").CopyHere oApp.Namespace(ThisWorkbook.Path).Items.Item("styles.xml")
  Set oApp = Nothing
  ' replace original file
  Kill PathFilename
  Name ZipFileName As PathFilename




End Sub


 
Sub Test()
 
  Dim lStart&, lStop&, avarData$
 
  avarData = "Dummy123" _
           & csSTYLES_START & " count='3'" _
           & "(cellStyle name='Normal' xfId='0' builtinId='0' /)" _
           & "(cellStyle name='Style 1' xfId='1' /)" _
           & "(cellStyle name='Style 2' xfId='2' /)" _
           & csSTYLES_CLOSE _
           & "Dummy456"
  avarData = Replace(avarData, "(", vbLf & "<")
  avarData = Replace(avarData, ")", "<")
 
  lStart = InStr(1, avarData, csSTYLES_START, vbBinaryCompare)
  lStop = InStr(1, avarData, csSTYLES_CLOSE, vbBinaryCompare)
  Debug.Print "lStart = " & lStart, "lStop = " & lStop
 
  avarData = Left$(avarData, lStart - 1) & csDEFAULT_STYLES & Mid$(avarData, lStop + Len(csSTYLES_CLOSE))
  Debug.Print avarData
  Debug.Print Replace(avarData, csDEFAULT_STYLES, "")
 
End Sub


Sub Demo()
    Dim lngCount As Long
    Dim cl As Range


    Set cl = ActiveCell
    ' Open the file dialog
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = False
        .Show
        ' Display paths of each file selected
        For lngCount = 1 To .SelectedItems.Count
            ' Add Hyperlinks
            cl.Worksheet.Hyperlinks.Add _
                Anchor:=cl, Address:=.SelectedItems(lngCount), _
                TextToDisplay:=.SelectedItems(lngCount)
            ' Add file name
            'cl.Offset(0, 1) = _
            '    Mid(.SelectedItems(lngCount), InStrRev(.SelectedItems(lngCount), "\") + 1)
            ' Add file as formula
            cl.Offset(0, 1).FormulaR1C1 = _
                 "=TRIM(RIGHT(SUBSTITUTE(RC[-1],""\"",REPT("" "",99)),99))"




            Set cl = cl.Offset(1, 0)
        Next lngCount
    End With
End Sub

Thanks for all of your help Vladimir!