Using collections in VBA instead of dictionary-CodePudding

How can I replicate the following code with VBA collections rather than dictionaries? (I cannot access from Tools / References... / "Microsoft Scripting Runtime" at work)

The idea is to clean up any unused styles in VBA (https://stackoverflow.com/a/8933399/19794809)

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

    Set wb = ThisWorkbook ' choose this module's workbook

    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

    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  

    ' 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

    MsgBox "ENDING # of style in workbook: " & wb.Styles.Count

End Sub

CodePudding user response：

Try using late binding and see if that works.

Public Sub DropUnusedStylesWithDictionary()
    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
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Set wb = ThisWorkbook ' choose this module's workbook

    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

    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

    ' 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

    MsgBox "ENDING # of style in workbook: " & wb.Styles.Count
    Set dict = Nothing
End Sub

CodePudding user response：

Here is code using Collections as the original poster requested.

Public Sub DropUnusedStylesWithCollections()
    Dim styleObj As Style
    Dim rngCell As Range
    Dim wb As Workbook
    Dim wsh As Worksheet
    Dim str As String
    Dim sKey As String
    Dim lIndex As Long
    Dim iStyleCount As Long
    Dim oKeys As New Collection
    Dim oValues As New Collection

    Set wb = ThisWorkbook ' choose this module's workbook

    MsgBox "BEGINNING # of styles in workbook: " & wb.Styles.Count

    ' oCollection := list of styles
    For Each styleObj In wb.Styles
        str = styleObj.NameLocal
        iStyleCount = iStyleCount   1
        Call oKeys.Add(str)    ' First time:  adds keys
        Call oValues.Add(0)    ' First time:  initialize
    Next styleObj

    For Each wsh In wb.Worksheets
        If wsh.Visible Then
            For Each rngCell In wsh.UsedRange.Cells
                str = rngCell.Style
                Call UpdateValuesCollection(oKeys, oValues, str)     ' This time:  counts occurrences
            Next rngCell
        End If
    Next wsh

    ' Try to delete unused styles
    On Error Resume Next    ' wb.Styles(aKey).Delete may throw error

    For lIndex = 1 To oKeys.Count

        ' display count & stylename
        '    e.g. "24   Normal"
        Debug.Print oValues(lIndex) & vbTab & oKeys.Item(lIndex)

        If oValues.Item(lIndex) = 0 Then
            ' Occurrence count (Item) indicates this style is not used
            Call wb.Styles(lkeys.Item(lIndex)).Delete
            If Err.Number <> 0 Then
                Debug.Print vbTab & "^-- failed to delete"
                Err.Clear
            End If
            Call oKeys.Remove(oKeys.Item(lIndex))
        End If

    Next lIndex

    MsgBox "ENDING # of style in workbook: " & wb.Styles.Count
    Set oCollection = Nothing
End Sub

Private Sub UpdateValuesCollection(oKeys As Collection, oValues As Collection, sKey As String, Optional bCaseSensitive As Boolean = False)
    Dim lIndex As Long, lCount As Long
    Dim bMatched As Boolean
    
    For lIndex = 1 To oKeys.Count
        lCount = oValues.Item(lIndex)   1
        bMatched = False
        If bCaseSensitive Then
            If oKeys.Item(lIndex) = sKey Then
                bMatched = True
            End If
        Else
            If StrComp(oKeys.Item(lIndex), sKey, vbTextCompare) = 0 Then
                bMatched = True
            End If
        End If
        If bMatched Then
            Call oValues.Remove(lIndex)
            Call oValues.Add(lCount, sKey)
            Exit For
        End If
    Next lIndex
End Sub

CodePudding user response：

Another collection-based approach:

Public Sub DropUnusedStyles()

    Dim wb As Workbook, wsh As Worksheet, str As String, arr, i As Long
    Dim colStyles As New Collection, c As Range, styleObj As Style
    
    Set wb = ThisWorkbook ' choose this module's workbook
    'first scan all of the used styles
    For Each wsh In wb.Worksheets
        If wsh.Visible Then
            For Each c In wsh.UsedRange.Cells
                str = c.Style
                arr = KeyValue(colStyles, str) 'any existing collection entry?
                
                If IsEmpty(arr) Then
                    'first instance of this style
                    colStyles.Add Array(str, 1), str
                Else
                    'exists - remove and replace, incrementing count
                    colStyles.Remove str
                    colStyles.Add Array(str, arr(1)   1), str
                End If
            Next c
        End If
    Next wsh
    
    'list found styles
    Debug.Print "----------Used Styles-------"
    For Each arr In colStyles
        Debug.Print Join(arr, " = ")
    Next arr
    
    'review all workbook styles
    Debug.Print "----------Review Styles-------"
    For i = wb.Styles.Count To 1 Step -1 'deleting, so step backwards
        Set styleObj = wb.Styles(i)
        str = styleObj.NameLocal
        arr = KeyValue(colStyles, str)
        If IsEmpty(arr) Then
            Debug.Print str & "   #Delete#"  'delete this style
            styleObj.Delete 'remove the unused style
        Else
            Debug.Print str & " has " & arr(1) & " uses"
        End If
    Next i
End Sub

'return a collection value from a key, or Empty if key doesn't exist
Function KeyValue(col As Collection, key As String) As Variant
    Dim v As Variant
    On Error Resume Next
    v = col(key)
    On Error GoTo 0
    KeyValue = v
End Function