­ã´£³¡ªL

Sub TEST()
Dim Arr, xD, N&, i&, j%
Arr = Range([A1], [B65536].End(xlUp)(1, 2))
Set xD = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(Arr)
    xD(Arr(i, 2) & "") = xD(Arr(i, 2) & "") + 1
Next
For i = 2 To UBound(Arr)
    If xD(Arr(i, 2) & "") > 5 Then GoTo 101
    N = N + 1
    For j = 1 To 3: Arr(N + 1, j) = Arr(i, j): Next
101: Next
If N > 0 Then [H2].Resize(N + 1, 3) = Arr
End Sub