Excel Macros : Remove Duplicates Excel

Excel 2007 has built in command to remove duplicates, however earlier versions of excel does not have built in command. You need to use VBA routine to do the job.

Use following code to Identify duplicate values in a column and Remove Rows having Duplicate Values

After identifying the duplicate values system will give you warning and ask for confirmation to delete the entire row(s) having duplicate values. You can choose No in case you do not want to delete them.

You will need to copy this code to regular VBA module of your workbook

Sub Find_RemoveDuplicates() '**************************************************************************************************** '* Macro recorded by Yogesh Gupta, smiley123z@gmail.com, Ygblogs.blogspot.com on September 9, 2009 * '* Macro Modified on September 13, 2009 for not deleting empty cells within duplicate values column * '**************************************************************************************************** Dim cRow As Long Dim lRow As Long Dim sCell As Range Dim D As Long lRow = GetLastRowWithData On Error Resume Next Set sCell = Application.InputBox(Prompt:= _ "Select Starting Row of Column with Duplicate values.", _ Title:="Select Column", Type:=8) On Error GoTo 0 If sCell Is Nothing Then Exit Sub End If sCell.Select If Selection.Cells.Count > 1 Then MsgBox ("Pls select Single Cell only") Exit Sub Else dCol = ActiveCell.Column sRow = ActiveCell.Row For cRow = lRow To sRow Step -1 If IsEmpty(Cells(cRow, dCol)) = False Then If WorksheetFunction.CountIf(Range(sCell, Cells(cRow, dCol)), Cells(cRow, dCol).Text) > 1 Then Cells(cRow, dCol).Interior.Color = 255 'This Marks the duplicate values as Red D = D + 1 End If End If Next cRow If D = 0 Then MsgBox ("No Duplicate Values Found") Else caution = MsgBox(D & " Duplicate entries selected and marked RED" & vbCrLf & _ "Do you want to delete them? " & vbCrLf & _ "Entire Row for the marked entries will be deleted. " & vbCrLf & _ "Do you want to Continue?", vbYesNo, "Confirmation") If caution = vbYes Then For cRow = lRow To sRow Step -1 If IsEmpty(Cells(cRow, dCol)) = False Then If WorksheetFunction.CountIf(Range(sCell, Cells(cRow, dCol)), Cells(cRow, dCol).Text) > 1 Then Cells(cRow, dCol).EntireRow.Delete ' This deletes the entire row End If End If Next cRow End If End If End If End Sub '******************************************************************** '* UDF to Get Last Row with Data on worksheet * '******************************************************************** Public Function GetLastRowWithData() As Long Dim ExcelLastCell As Object, lRow As Long, lLastDataRow As Long, l As Long Set ExcelLastCell = ActiveSheet.Cells.SpecialCells(xlLastCell) lLastDataRow = ExcelLastCell.Row lRow = ExcelLastCell.Row Do While Application.CountA(ActiveSheet.Rows(lRow)) = 0 And lRow <> 1 lRow = lRow - 1 Loop lLastDataRow = lRow GetLastRowWithData = lLastDataRow End Function

Download file having Macro to Find and Remove Duplicates in Excel.

Above works well in case you are trying to clean a data table on the sheet, however if you have lots of other data also on the sheet, you should try the Find and Remove duplicates within Range



You will need to copy this code to regular VBA module of your workbook

Sub Find_RemoveDuplicatesWithinRange() '*************************************************************************************************** '* Macro recorded by Yogesh Gupta, smiley123z@gmail.com, Ygblogs.blogspot.com on September 13, 2009 * '*************************************************************************************************** Dim cRow As Long Dim sRow As Long Dim lRow As Long Dim sCol As Long Dim lCol As Long Dim dColumn As Long Dim D As Long Dim sCell As Range Dim dRange As Range On Error Resume Next Set dRange = Application.InputBox(Prompt:= _ "Select Data Range with Duplicate values.", _ Default:=Selection.Address, Title:="Select Range", Type:=8) If dRange Is Nothing Then Exit Sub End If With dRange sRow = Cells(.Row, .Column).Row sCol = Cells(.Row, .Column).Column lCol = Cells(.Row, .Column + .Columns.Count - 1).Column lRow = Cells(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1).Row End With dColumn = 0 Do While dColumn = 0 Set sCell = Application.InputBox(Prompt:= _ "Select Column with Duplicate values.", _ Title:="Select Column", Type:=8) On Error GoTo 0 If sCell Is Nothing Then Exit Sub End If If sCell.Columns.Count > 1 Then MsgBox ("Pls select Single Column only") Else dCol = sCell.Column If dCol < sCol Then MsgBox ("Select Column within earlier Range") ElseIf dCol > lCol Then MsgBox ("Select Column within earlier Range") Else dColumn = 1 End If End If Loop For cRow = lRow To sRow Step -1 If IsEmpty(Cells(cRow, dCol)) = False Then If WorksheetFunction.CountIf(Range(Cells(sRow, dCol), Cells(cRow, dCol)), Cells(cRow, dCol).Text) > 1 Then Range(Cells(cRow, sCol), Cells(cRow, lCol)).Select Selection.Interior.Color = 255 D = D + 1 End If End If Next cRow Cells(sRow, sCol).Select If D = 0 Then MsgBox ("No Duplicate Values Found") Else caution = MsgBox(D & " Duplicate entries selected and marked RED" & vbCrLf & _ "Do you want to delete them? " & vbCrLf & _ "Marked entries will be deleted and data will move up " & vbCrLf & _ "Do you want to Continue?", vbYesNo, "Confirmation") If caution = vbYes Then For cRow = lRow To sRow Step -1 If IsEmpty(Cells(cRow, dCol)) = False Then If WorksheetFunction.CountIf(Range(Cells(sRow, dCol), Cells(cRow, dCol)), Cells(cRow, dCol).Text) > 1 Then Range(Cells(cRow, sCol), Cells(cRow, lCol)).Select Selection.Delete Shift:=xlUp End If End If Next cRow Cells(sRow, sCol).Select End If End If End Sub

Download file having macro to find and remove duplicates within a range

Delete Duplicates , Delete Duplicate , Remove Duplicates , Remove Duplicate , Find Duplicates , Find Duplicate , Excel Delete Duplicates , Remove Duplicates Excel , Remove Duplicate Excel