Sub s()
arr = Selection
Set d = CreateObject("scripting.dictionary")
n = UBound(arr)
ReDim brr(1 To n)
For i = 1 To n
t = CStr(arr(i, 1)) & CStr(arr(i, 2))
d(t) = d(t) + 1
Next
For i = 1 To n
t = CStr(arr(i, 1)) & CStr(arr(i, 2))
brr(i) = d(t)
Next
Selection.Offset(, 2).Resize(n, 1) = Application.Transpose(brr)
End Sub