Sub deletedups()
Dim e
With CreateObject("Scripting.Dictionary")
For Each e In ActiveSheet.UsedRange
If Not .exists(e.Value) Then
.Add e.Value, Empty
Else: e.Value = Empty
End If
Next
End With
Application.ScreenUpdating = 0
ActiveSheet.UsedRange.SpecialCells(4).Delete xlUp
End Sub