Unique count of words from text string

The following is a rough approach, and is open to tons of improvements, but should get you started.

Read the comments and adjust the code to fit your needs.

Option Explicit


Public Sub CountWordsInColumn()
    
    ' Adjust to set the sheet holding the data
    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Worksheets("DataSet")
    
    ' Adjust the column and row that contains the hits
    Dim hitsColumn As String
    Dim hitsStartRow As Long
    Dim lastRow As Long
    hitsColumn = "C"
    hitsStartRow = 2
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, hitsColumn).End(xlUp).Row
    
    ' Adjust the column that contains the hits
    Dim sourceRange As Range
    Set sourceRange = sourceSheet.Range(hitsColumn & hitsStartRow & ":" & hitsColumn & lastRow)
    
    ' Add values in each cell split by ,
    Dim evalCell As Range
    Dim splitValues As Variant
    Dim counter As Long
    ReDim splitValues(lastRow - hitsStartRow)
    For Each evalCell In sourceRange
    
        splitValues(counter) = Split(evalCell.Value, ",")
        
        counter = counter + 1
        
    Next evalCell
    
    ' Get all values into an array
    Dim allValues As Variant
    allValues = AddValuesToArray(splitValues)
    
    ' Get unique values into an array
    Dim uniqueValues As Variant
    uniqueValues = GetUniqueValues(allValues)
    
    ' Count duplicated values from unique array
    Dim outputData As Variant
    outputData = CountValuesInArray(uniqueValues, allValues)
    
    ' Add new sheet
    Dim outputSheet As Worksheet
    Set outputSheet = ThisWorkbook.Sheets.Add
    PrintArrayToSheet outputSheet, outputData

End Sub

Private Function AddValuesToArray(ByVal myArray As Variant) As Variant

    Dim counter As Long
    Dim tempArray As Variant
    Dim tempCounter As Long
    Dim tempArrayCounter As Long
    
    ReDim tempArray(0)
    
    For counter = 0 To UBound(myArray)
        
        For tempCounter = 0 To UBound(myArray(counter))
            
            tempArray(tempArrayCounter) = myArray(counter)(tempCounter)
            
            tempArrayCounter = tempArrayCounter + 1
            
            ReDim Preserve tempArray(tempArrayCounter)
        
        Next tempCounter
    
    Next counter
    
    ReDim Preserve tempArray(tempArrayCounter - 1)
    
    AddValuesToArray = tempArray

End Function

Private Function GetUniqueValues(ByVal tempArray As Variant) As Variant
    Dim tempCol As Collection
    Set tempCol = New Collection
    
    On Error Resume Next
    Dim tempItem As Variant
    For Each tempItem In tempArray
        tempCol.Add tempItem, CStr(tempItem)
    Next
    On Error GoTo 0
    
    Dim uniqueArray As Variant
    Dim counter As Long
    ReDim uniqueArray(tempCol.Count - 1)
    For Each tempItem In tempCol
        uniqueArray(counter) = tempCol.Item(counter + 1)
        counter = counter + 1
    Next tempItem
    GetUniqueValues = uniqueArray
    
End Function

Function CountValuesInArray(ByVal uniqueArray As Variant, ByVal allValues As Variant) As Variant
    
    Dim uniqueCounter As Long
    Dim allValuesCounter As Long
    Dim ocurrCounter As Long
    Dim outputData As Variant
    
    ReDim outputData(UBound(uniqueArray))
    
    For uniqueCounter = 0 To UBound(uniqueArray)
    
        For allValuesCounter = 0 To UBound(allValues)
        
            If uniqueArray(uniqueCounter) = allValues(allValuesCounter) Then ocurrCounter = ocurrCounter + 1
        
        Next allValuesCounter
        
        ' This is the output
        Debug.Print uniqueArray(uniqueCounter), ocurrCounter
        outputData(uniqueCounter) = Array(uniqueArray(uniqueCounter), ocurrCounter)
        
        ocurrCounter = 0
    
    Next uniqueCounter
    
    CountValuesInArray = outputData
    
End Function

Private Sub PrintArrayToSheet(ByVal outputSheet As Worksheet, ByVal outputArray As Variant)

    Dim counter As Long
    
    For counter = 0 To UBound(outputArray)
    
        outputSheet.Cells(counter + 1, 1).Value = outputArray(counter)(0)
        outputSheet.Cells(counter + 1, 2).Value = outputArray(counter)(1)
    
    Next counter
End Sub