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