How to Find and Remove duplicate values in Microsoft Excel
In this tutorial you will learn various method of finding and removing duplicate values in Microsoft Excel
'To find duplicates in the selected range
Sub FindDuplicateValues()
Dim cellRange, searcCellRange, cell As range
Dim duplicateCells, selRange, seperator As String
Set cellRange = Selection
seperator = "||||"
For Each cell In cellRange.Cells
If cell.Value 〈〉 "" Then
If InStr(1, selRange, cell.Value & seperator) = 0 Then
selRange = selRange & cell.Value & seperator
Set searcCellRange = cellRange.Find(what:=cell.Value, LookIn:=xlValues, _
lookat:=xlWhole, searchdirection:=xlNext)
If Not searcCellRange Is Nothing Then
FirstAddress = searcCellRange.Address
Do
Set searcCellRange = cellRange.FindNext(searcCellRange)
If searcCellRange.Address = FirstAddress Then Exit Do
duplicateCells = duplicateCells & searcCellRange.Address & ","
Loop
End If
End If
End If
Next cell
If duplicateCells 〈〉 "" Then
Set cellRange = range(Left(duplicateCells, Len(duplicateCells) - 1))
UserAnswer = MsgBox(cellRange.Count & " duplicate values were found," _
& " would you like them to be highlighted in red?", vbYesNo)
If UserAnswer = vbYes Then cellRange.Interior.Color = vbRed
Else
MsgBox "No duplicate cell values were found"
End If
End Sub
'To remove duplicates in the selected range
Sub RemoveDuplicates()
Dim cellRange, searcCellRange, cell As range
Dim duplicateCells, selRange, seperator As String
Set cellRange = Selection
seperator = "||||"
For Each cell In cellRange.Columns(1).Cells
If cell.Value 〈〉 "" Then
If InStr(1, selRange, cell.Value & seperator) = 0 Then
selRange = selRange & cell.Value & seperator
Set searcCellRange = cellRange.Find(what:=cell.Value, LookIn:=xlValues, _
lookat:=xlWhole, searchdirection:=xlNext)
If Not searcCellRange Is Nothing Then
FirstAddress = searcCellRange.Address
Do
Set searcCellRange = cellRange.FindNext(searcCellRange)
If searcCellRange.Address = FirstAddress Then Exit Do
Set searcCellRange = searcCellRange.Resize(1, cellRange.Columns.Count)
duplicateCells = duplicateCells & searcCellRange.Address & ","
Loop
End If
End If
End If
Next cell
If duplicateCells 〈〉 "" Then
Set cellRange = range(Left(duplicateCells, Len(duplicateCells) - 1))
cellRange.Select
UserAnswer = MsgBox(cellRange.Count & " duplicate values were found," _
& " would you like to delete any duplicate rows found?", vbYesNo)
If UserAnswer = vbYes Then Selection.Delete Shift:=xlUp
Else
MsgBox "No duplicate cell values were found"
End If
End Sub