Sub Do_It()
Dim arr As Variant
Dim arrSplit As Variant
Dim vntItem As Variant
Dim objphrase As Object
Dim objkeys As Object

Dim lngItem As Long, lngkeys As Long

Set objphrase = CreateObject("scripting.dictionary")
Set objkeys = CreateObject("scripting.dictionary")

'Get Data of Column C
With ActiveSheet
    arr = .Range("C2:C" & .Cells(Rows.Count, 3).End(xlUp).Row).Value
End With

For lngItem = 1 To UBound(arr, 1)
    'just in case...
    arr(lngItem, 1) = Trim(CStr(arr(lngItem, 1)))
    If Not arr(lngItem, 1) = "" Then
        'makes things easier ...
        arr(lngItem, 1) = " " & arr(lngItem, 1) & " "
        'Collect and count phrases
        If objphrase.Exists(arr(lngItem, 1)) Then
            objphrase(arr(lngItem, 1)) = objphrase(arr(lngItem, 1)) + 1
        Else
            objphrase(arr(lngItem, 1)) = 1
        End If
        'extract keys
        arrSplit = Split(arr(lngItem, 1), " ")
        'Collect and count keys
        For lngkeys = 1 To UBound(arrSplit) - 1
            If objkeys.Exists(arrSplit(lngkeys)) Then
                objkeys(arrSplit(lngkeys)) = objkeys(arrSplit(lngkeys)) + 1
            Else
                objkeys(arrSplit(lngkeys)) = 1
            End If
        Next lngkeys
    End If
Next lngItem

 'Report
With ActiveSheet
    If objkeys.Count > 0 Then
        lngItem = 0
        ReDim arr(1 To objkeys.Count, 1 To 2)
        For Each vntItem In objkeys
            lngItem = lngItem + 1
            arr(lngItem, 1) = vntItem
            arr(lngItem, 2) = objkeys(vntItem)
        Next vntItem
        .Cells(2, 5).Resize(UBound(arr, 1), 2).Value = arr
    End If
    If objphrase.Count > 0 Then
        lngItem = 0
        ReDim arr(1 To objphrase.Count, 1 To 2)
        For Each vntItem In objphrase
            lngItem = lngItem + 1
            arr(lngItem, 1) = vntItem
            arr(lngItem, 2) = objphrase(vntItem)
        Next vntItem
        .Cells(2, 7).Resize(UBound(arr, 1), 2).Value = arr
    End If
End With

 'Clean up
Set objkeys = Nothing
Set objphrase = Nothing

End Sub