This tutorial explains how to identify duplicates in one or more columns using VBA in MS Excel.
You can download the following dataset to practice.
rng.FormatConditions.Add adds a new condition to the range for formatting purposes. Type:=xlExpression allows to create a formula that will be calculated for each cell in the range to check whether the condition is met or not.
FormatConditions.Interior.Color fills the cell with color if it satisfies the formatting condition.
Case I: For Single Column
The following code identifies duplicates in a single column (column A) using conditional formatting.
Sub ApplyConditionalFormattingForDuplicates()
Dim ws As Worksheet
Dim lastRow As Long
Dim rng As Range
Set ws = ThisWorkbook.ActiveSheet
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
Set rng = ws.Range("A1:A" & lastRow)
rng.FormatConditions.Delete
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF($A$1:$A$" & lastRow & ", A1)>1"
rng.FormatConditions(1).Interior.Color = vbRed
End Sub
Press Run or F5 to run the above code.
Case II: For Multiple Columns
In this case we highlight duplicates present in both the column A and B. Follow the code given below:
Sub ApplyConditionalFormattingForDuplicates()
Dim ws As Worksheet
Dim lastRow As Long
Dim rng As Range
Set ws = ThisWorkbook.ActiveSheet
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
Set rng = ws.Range("A1:B" & lastRow)
rng.FormatConditions.Delete
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF($A$1:$B$" & lastRow & ", A1)>1"
rng.FormatConditions(1).Interior.Color = vbRed
End Sub
Press Run or F5 to run the above code.
The COUNTIF function in Excel and VBA is used to count the number of cells in a range that meet a specific condition or criteria.
count = Application.WorksheetFunction.CountIf(rng, cell.Value). This code returns the number of times cell.Value repeats in the given range(rng).
Case I: For Single Column
The following code identifies duplicates in a single column (column A) using COUNTIF Function.
Sub IdentifyDuplicatesUsingCountIf()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim count As Long
Dim lastRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
Set rng = ws.Range("A1:A" & lastRow)
For Each cell In rng
If Not IsEmpty(cell.Value) Then
count = Application.WorksheetFunction.CountIf(rng, cell.Value)
If count > 1 Then
cell.Interior.Color = vbRed
End If
End If
Next cell
End Sub
Press Run or F5 to run the above code.
Case II: For Multiple Columns
The following code identifies duplicates in multiple columns (Column A and B) using COUNTIF Function.
Sub IdentifyDuplicatesUsingCountIf()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim count As Long
Dim lastRow As Long
Set ws = ThisWorkbook.Sheets("Sheet2")
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
Set rng = ws.Range("A1:B" & lastRow)
For Each cell In rng
If Not IsEmpty(cell.Value) Then
count = Application.WorksheetFunction.CountIf(rng, cell.Value)
If count > 1 Then
cell.Interior.Color = vbRed
End If
End If
Next cell
End Sub
Press Run or F5 to run the above code.
Case I: For Single Column
The following code identifies duplicates in a single column (column A) using For Each Loop.
Sub FindDuplicatesUsingForEach()
Dim ws As Worksheet
Dim lastRow As Long
Dim cell As Range
Dim compareCell As Range
Set ws = ThisWorkbook.ActiveSheet
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
For Each cell In ws.Range("A1:A" & lastRow)
For Each compareCell In ws.Range("A1:A" & lastRow)
If cell.Value = compareCell.Value And cell.Address compareCell.Address Then
compareCell.Interior.Color = vbRed
End If
Next compareCell
Next cell
End Sub
Press Run or F5 to run the above code.
Case II: For multiple columns
The following code identifies duplicates in multiple columns (column A and B) using COUNTIF Function.
Sub FindDuplicatesUsingForEach()
Dim ws As Worksheet
Dim lastRow As Long
Dim cell As Range
Dim compareCell As Range
Set ws = ThisWorkbook.ActiveSheet
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
For Each cell In ws.Range("A1:B" & lastRow)
For Each compareCell In ws.Range("A1:B" & lastRow)
If cell.Value = compareCell.Value And cell.Address compareCell.Address Then
compareCell.Interior.Color = vbRed
End If
Next compareCell
Next cell
End Sub
Press Run or F5 to run the above code.
Scripting.Dictionary ObjectScripting.Dictionary object store the values encountered in the dataset. While looping through the data if the value exists in the dictionary it means we have encountered a duplicate.
If it doesn’t exist then we add it to the dictionary.
Case I: For Single Column
The following code identifies duplicates in a single column (Column A) using “Scripting.Dictionary” method.
Sub FindDuplicatesWithDictionary()
Dim ws As Worksheet
Dim lastRow As Long
Dim lastColumn As Long
Dim iCntr As Long
Dim cellValue As Variant
Dim dict As Object
Dim key As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.ActiveSheet
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
For iCntr = 1 To lastRow
cellValue = ws.Cells(iCntr, 1).Value
If cellValue "" Then
If dict.Exists(cellValue) Then
ws.Cells(iCntr, 1).Interior.Color = vbRed
Else
dict.Add cellValue, True
End If
End If
Next iCntr
Set dict = Nothing
End Sub
Press Run or F5 to run the above code.
Case II: For Multiple Columns
The following code identifies the duplicates in multiple columns (Column A and B) using “Scripting.Dictionary” method.
Sub FindDuplicatesWithDictionary()
Dim ws As Worksheet
Dim lastRow As Long
Dim lastColumn As Long
Dim iCntr As Long
Dim iPntr As Long
Dim cellValue As Variant
Dim dict As Object
Dim key As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.ActiveSheet
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
lastColumn = ws.Cells(1, ws.Columns.count).End(xlToLeft).Column
For iPntr = 1 To lastColumn
For iCntr = 1 To lastRow
cellValue = ws.Cells(iCntr, iPntr).Value
If cellValue "" Then
If dict.Exists(cellValue) Then
ws.Cells(iCntr, iPntr).Interior.Color = vbRed
Else
dict.Add cellValue, True
End If
End If
Next iCntr
Next iPntr
Set dict = Nothing
End Sub
Press Run or F5 to run the above code.
Read MoreListenData
