79107008

Date: 2024-10-20 12:15:57
Score: 0.5
Natty:
Report link

As @eli-k suggested, I'm posting conclusions of my analysis. So, the main problem is pretty general - Excel can make troubles if there are many cell styles created. The solution - however a bit twisted - is to 'auto'-detect unique/duplicated styles and reduce the total number of them.

Steps of code:

  1. Iterate over all given cells.
  2. Regarding merged cells - analyze only the first one.
  3. Create an array that stores - selected by a user - properties of cell formatting.
  4. Convert all array values to string.
  5. Using any macro from here: hashing in VBA, convert array string to hash. This step is crucial for this code, because it creates unique style names as strings, so in fact combines values of various types (stored in array) into one. It also prevents from exceeding 255 characters limit.
  6. Check if a style of this hash exists. If no - add it as a new cell style.
  7. No matter if style already exists or not - apply style to analyzed cell.

Code:

Sub createApplyUniqueCellStyles( _
  rng As Range _
)

  'turning off ScreenUpdating and alerts
  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With
  
  'Workbook variable
  Dim wb As Workbook
  Set wb = rng.Worksheet.Parent

  Dim cll As Range
  Dim rngToAnalyze As Range

  'arrays for formatting values
  'before running this macro, consider properties and total number of properties to identify unique styles from
  Dim arrStyleProperties(1 To 27) As Variant
  Dim arrStylePropertiesToString(1 To 27) As String
  Dim i As Long
  
  Static lngNewStylesCount As Long

  For Each cll In rng
    
    'skipping merged cells - except the first one
    If cll.MergeCells Then
      Set rngToAnalyze = cll.MergeArea

      If Not cll.Address = rngToAnalyze.Cells(1, 1).Address Then
        GoTo nextIteration
      End If

    Else
      Set rngToAnalyze = cll
    End If
    
    With rngToAnalyze

      'numbers format
      arrStyleProperties(1) = .NumberFormat

      'font
      With .Font
        arrStyleProperties(2) = .Name
        arrStyleProperties(3) = .FontStyle
        arrStyleProperties(4) = .Size
        arrStyleProperties(5) = .Color
        arrStyleProperties(6) = .Bold
        arrStyleProperties(7) = .Italic
        arrStyleProperties(8) = .Underline
      End With

      'alignment
      arrStyleProperties(9) = .HorizontalAlignment
      arrStyleProperties(10) = .VerticalAlignment

      'text wrapping
      arrStyleProperties(11) = .WrapText

      'merge
      arrStyleProperties(12) = .MergeCells

      'cell interior
      With .Interior
        arrStyleProperties(13) = .Color
        arrStyleProperties(14) = .Pattern
        arrStyleProperties(15) = .PatternColorIndex
      End With

      'borders
      'left
      With .Borders(xlLeft)
        arrStyleProperties(16) = .LineStyle
        arrStyleProperties(17) = .Color
        arrStyleProperties(18) = .Weight
      End With

      'right
      With .Borders(xlRight)
        arrStyleProperties(19) = .LineStyle
        arrStyleProperties(20) = .Color
        arrStyleProperties(21) = .Weight
      End With

      'top
      With .Borders(xlTop)
        arrStyleProperties(22) = .LineStyle
        arrStyleProperties(23) = .Color
        arrStyleProperties(24) = .Weight
      End With

      'bottom
      With .Borders(xlBottom)
        arrStyleProperties(25) = .LineStyle
        arrStyleProperties(26) = .Color
        arrStyleProperties(27) = .Weight
      End With

    End With

    'array values to text
    For i = 1 To 27
      If IsNull(arrStyleProperties(i)) Then
        'CStr() doesn't convert Nulls
        arrStylePropertiesToString(i) = "Null"
      Else
        arrStylePropertiesToString(i) = CStr(arrStyleProperties(i))
      End If
    Next i

    Dim strArrJoined As String
    Dim strArrJoinedMD5StyleName As String
    'array string
    strArrJoined = Join(arrStylePropertiesToString, "_")
    'array string hash
    strArrJoinedMD5StyleName = MD5(strArrJoined)

    Dim stl As Style
    On Error Resume Next
    Set stl = wb.Styles(strArrJoinedMD5StyleName)
    On Error GoTo 0

    If stl Is Nothing Then
      'style not exists - add
      Set stl = wb.Styles.Add(strArrJoinedMD5StyleName, rngToAnalyze)

    End If
    
    'apply the style
    rngToAnalyze.Style = strArrJoinedMD5StyleName
   
    'release and erase
    Set stl = Nothing
    Erase arrStyleProperties
    Erase arrStylePropertiesToString

nextIteration:
  Next cll

  Set wb = Nothing
  Set cll = Nothing
  Set rng = Nothing
  Set rngToAnalyze = Nothing
  Erase arrStyleProperties
  Erase arrStylePropertiesToString
  Set stl = Nothing

End Sub

'https://en.wikibooks.org/wiki/Visual_Basic_for_Applications/String_Hashing_in_VBA
Function MD5(ByVal sIn As String, Optional bB64 As Boolean = 0) As String
  'Set a reference to mscorlib 4.0 64-bit
  'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
  'and not just Net Advanced Services
      
  'Test with empty string input:
  'Hex:   d41d8cd98f00...etc
  'Base-64: 1B2M2Y8Asg...etc
      
  Dim oT As Object, oMD5 As Object
  Dim TextToHash() As Byte
  Dim bytes() As Byte
      
  Set oT = CreateObject("System.Text.UTF8Encoding")
  Set oMD5 = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
  
  TextToHash = oT.Getbytes_4(sIn)
  bytes = oMD5.ComputeHash_2((TextToHash))
  
  If bB64 = True Then
    MD5 = ConvToBase64String(bytes)
  Else
    MD5 = ConvToHexString(bytes)
  End If
      
  Set oT = Nothing
  Set oMD5 = Nothing

End Function

Function ConvToBase64String(vIn As Variant) As Variant
  'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
  'and not just Net Advanced Services
   
  Dim oD As Object
  Set oD = CreateObject("MSXML2.DOMDocument")
   
  With oD
    .LoadXML "<root />"
    .DocumentElement.DataType = "bin.base64"
    .DocumentElement.nodeTypedValue = vIn
  End With
  
  ConvToBase64String = Replace(oD.DocumentElement.Text, vbLf, "")
    
  Set oD = Nothing

End Function

Function ConvToHexString(vIn As Variant) As Variant
  'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
  'and not just Net Advanced Services
  
  Dim oD As Object
  Set oD = CreateObject("MSXML2.DOMDocument")
      
  With oD
    .LoadXML "<root />"
    .DocumentElement.DataType = "bin.Hex"
    .DocumentElement.nodeTypedValue = vIn
  End With
  
  ConvToHexString = Replace(oD.DocumentElement.Text, vbLf, "")
    
  Set oD = Nothing

End Function

Concerning 5th step there are a couple of remarks:

  1. Hash functions are not used for security, but uniqueness identification. Choose a function that suits you best. I used MD5 because it's the simplest.
  2. Bear in mind that style name can be 255 characters long.
  3. As Wikibooks article states, for Windows 10+ it's necessary to install Net Framework 3.5.
  4. Consider converting hash string to base64. I chose not to convert, to avoid getting any potentially forbidden characters.

The code above can be used to reduce number of styles for any spreadsheet. However, code can take a lot of time to execute because it iterates over each cell from given range.

In the end, as it's SPSS-related question, I would recommend to delete all unused styles. Thankfully, SPSS styles have the same structure of name - style#*. Here's the code:

Sub deleteSPSSCellStyles()

  'turning off ScreenUpdating and alerts
  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With
  
  'Workbook variable
  Dim wb As Workbook
  Set wb = ThisWorkbook

  Dim stl As Style
  Dim strStyleName As String

  For Each stl In wb.Styles
    'no need to analyze built-in styles
    If Not stl.BuiltIn Then
      strStyleName = stl.Name
      If strStyleName Like "style#*" Then
        stl.Delete
      End If
    End If
  Next stl

  Set wb = Nothing
  Set stl = Nothing

End Sub
Reasons:
  • Long answer (-1):
  • Has code block (-0.5):
  • User mentioned (1): @eli-k
  • Self-answer (0.5):
  • Low reputation (0.5):
Posted by: Soren V. Raben