This macro is useful for removing duplicates on the selected data.
*************************************************************************
Code:
Sub RemoveDuplicate()
Dim ConstRange As Range, FrmRange As Range
Dim FullRange As Range, rCell As Range
Dim iCount As Long
Dim strAdd As String
DialogStyle = vbYesNo + vbCritical + vbDefaultButton2
Title = "Deleting Duplicates"
Msg = "Are you sure you want to delete entire rows?"
deleteDupRows = MsgBox(Msg, DialogStyle, Title)
If deleteDupRows = vbYes Then
On Error Resume Next
Set FullRange = Selection
If WorksheetFunction.CountA(FullRange) < 2 Then
MsgBox "Select more than one cell", vbInformation
On Error GoTo 0
Exit Sub
End If
Set ConstRange = FullRange.SpecialCells(xlCellTypeConstants)
Set FrmRange = FullRange.SpecialCells(xlCellTypeFormulas)
If Not ConstRange Is Nothing And Not FrmRange Is Nothing Then
Set FullRange = Union(ConstRange, FrmRange)
ElseIf Not ConstRange Is Nothing Then
Set FullRange = ConstRange
ElseIf Not FrmRange Is Nothing Then
Set FullRange = FrmRange
Else
MsgBox "Invalid Selection", vbInformation
On Error GoTo 0
Exit Sub
End If
Application.Calculation = xlCalculationManual
For Each rCell In FullRange
strAdd = rCell.Address
strAdd = FullRange.Find(What:=rCell, After:=rCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Address
If strAdd <> rCell.Address Then
rCell.Clear
End If
Next rCell
End If
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
*************************************************************************
