Hi bsrivatsa,

Try this (though initially on a copy of your data as the results cannot be undone if they're not as expected):

Option Explicit
Sub Macro3()

    Dim objMyUniqueData As Object
    Dim rngMyCell As Range
    Dim rngDelRange As Range
    Dim lngLastRow As Long
    Dim xlnCalcMethod As XlCalculation
    
    With Application
        .ScreenUpdating = False
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")

    lngLastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row

    For Each rngMyCell In Sheets("Sheet1").Range("A3:A" & lngLastRow)
        If Len(rngMyCell) > 0 Then
            If objMyUniqueData.Exists(CStr(rngMyCell)) = False Then
                objMyUniqueData.Add CStr(rngMyCell), rngMyCell
            Else
                If rngDelRange Is Nothing Then
                    Set rngDelRange = rngMyCell
                Else
                    Set rngDelRange = Union(rngDelRange, rngMyCell)
                End If
            End If
        Else
            If rngDelRange Is Nothing Then
                Set rngDelRange = rngMyCell
            Else
                Set rngDelRange = Union(rngDelRange, rngMyCell)
            End If
        End If
    Next rngMyCell
    
    If Not rngDelRange Is Nothing Then
        rngDelRange.EntireRow.Delete
    End If
    
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With

End Sub
Regards,

Robert