>>523
ここまでせんでもって思うけど
https://i.imgur.com/RQpkaWZ.png


Sub foo()

'準備
myarray = Array("aa", "bb", "cc")

'初期化
Set myDic = CreateObject("Scripting.Dictionary")
For Each x In myarray
myDic.Add x, 0
Next

'本体
最終行 = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To 最終行
For Each x In myarray
If InStr(Cells(i, 1), x) <> 0 Then
myDic(x) = myDic(x) + 1
Cells(i, 2).Value = myDic(x)
End If
Next
Next
End Sub