Sub dotest() '
Dim arr, d
Application.ScreenUpdating =False
Set d = CreateObject("Scripting.Dictionary")
With Sheets("Sheet2")
r =.Cells(.Rows.Count,"a").End(xlUp).Row
arr =.[a1].Resize(r,1)
End With
For i =2 To UBound(arr)
s = arr(i,1)
d(s)= d(s)+1
Next
With Sheets("Sheet1")
r =.Cells(.Rows.Count,"a").End(xlUp).Row
arr =.[a1].Resize(r,2)
For i =2 To UBound(arr)
s = arr(i,1)
If d.exists(s) Then
If d(s)>1 Then
arr(i,2)= d(s)
Else
arr(i,2)=""
End If
End If
Next
.[a1].Resize(r,2)= arr
End With
Set d = Nothing
Application.ScreenUpdating =True
MsgBox "OK!"
End Sub