VBA "Scripting.Dictionary" Word Occurences under each category

I am very new to dictionaries in VBA but I found a macro that does almost exactly what I need it to in a fraction of the time as a formula. I have a list of items that belong to different categories. In one column I have the category, in columns next to it I have the product title, description, and a few bullet points with more descriptions. My goal is to have a macro go through all the items in my sheet and return a list of words in those columns and their occurences in each category.

I've attached a sample with some dummy data. Dummy_Data.xlsx

Below is the code that I found at this page.

Sub HTH() 
    Dim vArray As Variant 
    Dim lLoop As Long 
    Dim rCell As Range 
     
    With CreateObject("Scripting.Dictionary") 
        For Each rCell In Range("A1", Cells(Rows.Count, "A").End(xlUp)) 
            vArray = Split(rCell.Value, " ") 
            For lLoop = LBound(vArray) To UBound(vArray) 
                If Not .exists(vArray(lLoop)) Then 
                    .Add vArray(lLoop), 1 
                Else 
                    .Item(vArray(lLoop)) = .Item(vArray(lLoop)) + 1 
                End If 
            Next lLoop 
        Next rCell 
        Range("B1").Resize(.Count).Value = Application.Transpose(.keys) 
        Range("C1").Resize(.Count).Value = Application.Transpose(.items) 
    End With 
End Sub

This code gives me the count of each word's occurence. The shortcoming here is that it includes special characters. For example: Ther could be the word "great" and "great," and each one would have their own count. My goal is to eliminate the special characters before counting. Also, I would like it to give me the word and the count within each category.

This next request is only optional but would be great. I would also like to get a list of two word combinations and their counts. For example if a phrase contained "big dog" then it would be counted. If a phrase contained "Big bad dog" then "Big Bad" and "Bad Dog" would be counted.

Also, I would like it so it isn't case sensitive when counting.

Any help on this would be greatly appreciated.

Hello manofcheese,

This was quite a challenge. While the code you provide is small, I believe your actual data is probably quite large. I tweaked the macro several times to get the best performance possible.

The data is output on "Sheet2" with each category's words and count listed in 2 columns with the category header in row 1. Each category is separated from the next by 1 empty column for readability.

Provided that your actual data is laid out the same as the example and is located on "Sheet1", you should be able to paste the macro into your original workbook with no problems. If you do encounter a problem, please post the workbook for review.


Macro Code

Sub Summarize()

    Dim Categories  As Variant
    Dim Category    As Variant
    Dim Data        As Variant
    Dim Dict        As Object
    Dim index       As Long
    Dim info        As Variant
    Dim n           As Long
    Dim RegExp      As Object
    Dim Rng         As Range
    Dim row         As Long
    Dim text        As String
    Dim Wks         As Worksheet
    Dim Word        As Variant
    Dim Words       As Variant
        
        Set Wks = Worksheets("Sheet1")
        Set Rng = Wks.Range("A1").CurrentRegion
        
        Set Dict = CreateObject("Scripting.Dictionary")
        Dict.CompareMode = vbTextCompare
        
        Set RegExp = CreateObject("VBScript.RegExp")
        RegExp.Global = True
        RegExp.Pattern = "[^\s0-9A-Za-z]+"
            
            Categories = Intersect(Rng, Rng.Columns(1).Offset(1, 0)).Value
        
            Data = Intersect(Rng, Rng.Offset(1, 1)).Value
        
            For row = 1 To UBound(Categories, 1)
                Category = Categories(row, 1)
                
                
                If Not Dict.exists(Category) Then
                    ReDim info(1, 0)
                    GoSub GetWordCount
                    Dict.Add Category, info
                Else
                    info = Dict(Category)
                    GoSub GetWordCount
                    Dict(Category) = info
                End If
            Next row
                       
        Application.ScreenUpdating = False
        
        n = 0
        
        For Each Key In Dict.Keys
            Item = Dict(Key)
            Sheet2.Range("A1").Offset(0, n) = Key
            Sheet2.Range("A1").Offset(1, n).Resize(UBound(Item, 2), 2) = Application.Transpose(Item)
            n = n + 3
        Next Key
      
        Application.ScreenUpdating = True
        
Exit Sub

GetWordCount:
            Words = Application.index(Data, row, 0)
            text = Join(Words, " ")
            text = RegExp.Replace(text, "")
            Words = Split(text, " ")
                    
            For Each Word In Words
                n = UBound(info, 2)
                index = 0
                    
                For j = 0 To UBound(info, 2) - 1
                    If StrComp(info(0, j), Word, vbTextCompare) = 0 Then
                        index = j
                        Exit For
                    End If
                Next j
                        
                If index = 0 Then
                    info(1, n) = info(1, n) + 1
                    info(0, n) = Word
                    ReDim Preserve info(1, n + 1)
                Else
                    info(1, index) = info(1, index) + 1
                End If
            Next Word
        Return

End Sub

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

Hello manofcheese,

You're welcome. Glad I help.