Option Explicit
Sub 按指定条件计算结果()
Dim a, i, j, t, d
Set d = CreateObject("scripting.dictionary")
a = [a1].CurrentRegion.Resize(, 2).Value
For i = 2 To UBound(a)
t = Split(a(i, 2), "、")
For j = 0 To UBound(t)
d(t(j)) = d(t(j)) + 1
Next
Next
[d2].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
End Sub