VBA "Scripting.Dictionary" Word Occurences under each category

Hello manofcheese,

After a lot of testing, checking, re-checking, and code tweaking, this macro is optimized. When I first started rewriting the macro, it took 3 minutes. Now, it takes a little over 2 seconds. This should work with no problem on your larger workbook.

If you have any problems, let me know.

Updated Macro Code

Sub Summarize()

    Dim Categories  As Variant
    Dim Category    As Variant
    Dim Data        As Variant
    Dim Dict        As Object
    Dim DstRng      As Object
    Dim DstWks      As Worksheet
    Dim Info        As Object
    Dim j           As Long
    Dim key         As Variant
    Dim n           As Long
    Dim RegExp      As Object
    Dim Rng         As Range
    Dim row         As Long
    Dim SrcWks      As Worksheet
    Dim text        As String
    Dim Word        As Variant
    Dim Words       As Variant
        
        StartTime = Timer
        
        Set DstWks = Worksheets("Sheet2")
        
        Set SrcWks = Worksheets("Sheet1")
        Set Rng = SrcWks.Range("A1").CurrentRegion
        
        Set Dict = CreateObject("Scripting.Dictionary")
        Dict.CompareMode = vbTextCompare
        
        Set RegExp = CreateObject("VBScript.RegExp")
        RegExp.Global = True
        RegExp.Pattern = "([\-]+)|([^\sA-Za-z]+)"
            
            Categories = Intersect(Rng, Rng.Columns(1).Offset(1, 0)).Value
        
            Data = Intersect(Rng, Rng.Offset(1, 2)).Value
        
            For row = 1 To UBound(Categories, 1)
                DoEvents
                
                Category = Categories(row, 1)
                
                If Not Dict.Exists(Category) Then
                    Set Info = CreateObject("Scripting.Dictionary")
                    Info.CompareMode = vbTextCompare
                    GoSub GetWordCount
                    Dict.Add Category, Info
                Else
                    Set Info = Dict(Category)
                    GoSub GetWordCount
                    Set Dict(Category) = Info
                End If
            Next row
                       
        Application.ScreenUpdating = False
        
        n = 0
        
        For Each key In Dict.Keys
            Set Info = Dict(key)
            
            Set DstRng = DstWks.Range("A1:B1").Offset(0, n).Resize(Info.Count, 2)
            
            DstRng.Range("A1:B1").Value = Array(key, "Count")
            
            DstRng.Columns(1).Offset(1, 0).Value = Application.Transpose(Info.Keys)
            DstRng.Columns(1).Cells.NumberFormat = "@"
            
            DstRng.Columns(2).Offset(1, 0).Value = Application.Transpose(Info.Items)
            DstRng.Columns(2).Cells.NumberFormat = "0;;;@"
            
            With DstWks.Sort
                .SortFields.Clear
                .SortFields.Add key:=DstRng.Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending
            
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SetRange DstRng
                .Apply
            End With
            
            n = n + 3
        Next key
      
        Application.ScreenUpdating = True
        
        EndTime = Timer
        TotalTime = EndTime - StartTime
        
Exit Sub

GetWordCount:
            text = ""
            Words = Empty
            
            For j = 1 To UBound(Data, 2)
                text = RegExp.Replace(Data(row, j), "$2 ")  ' Replace hyphens with a space.
                text = RegExp.Replace(text, "$1")           ' Remove all other punctuation except for spaces.
                Words = Split(text, " ")
                    
                For Each Word In Words
                    If Len(Word) > 0 Then
                        
                        If Not Info.Exists(Word) Then
                            Info.Add Word, 1
                        Else
                            n = Info(Word)
                            Info(Word) = n + 1
                        End If
                        
                    End If
                Next Word
            Next j
        
        Return

End Sub