Sub es()
Dim m As Object, c As Range, i, a
Set m = CreateObject("scripting.dictionary")
For Each c In Range("a2:b" & Cells(Rows.Count, 1).End(3).Row)
a = Split(c, " ")
For Each i In a
If UCase(i) = i And i <> "" Then m(i) = m(i) + 1
Next i: Next c
[d2].Resize(m.Count) = Application.Transpose(m.keys)
[e2].Resize(m.Count) = Application.Transpose(m.items)
End Sub