求大神给出完美解决啊

Sub test()
Dim i&, d As Object, c, s$, stmp$
Set d = CreateObject("scripting.dictionary")
For i = 2 To [a65536].End(3).Row
stmp = Cells(i, 1)
d(stmp) = d(stmp) + 1
Next i
For Each c In d.keys
If d(c) < 3 Then
s = s & Chr(10) & c & "少于三次，少于" & 3 - d(c) & "次"
End If
Next c
If s <> "" Then MsgBox Mid(s, 2)
End Sub