السلام عليكم
بعد إذن الاستاذ بن عليه
هذا كود بحلقات التكرار
Sub Abu_Ahmed()
Dim cl As Range: T = 3
Set MyRng = Range("B3:B" & Range("B65000").End(xlUp).Row)
Set MyRng1 = Range("A3:A" & Range("B65000").End(xlUp).Row)
MyRng1.Value = ""
For Each cl In MyRng
X = Application.CountIf(Range("B3:B" & T), cl)
If X = 1 Then cl.Offset(0, -1) = Application.Max(MyRng1) + 1
If X > 1 Then
For Each cll In MyRng
If cll = cl Then cl.Offset(0, -1) = cll.Offset(0, -1): Exit For
Next
End If
T = T + 1
Next
Set MyRng = Nothing: Set MyRng1 = Nothing
End Sub