Excel VB | duplicate range highlight and remove

This post is a follow up to the unique random numbers post - I have included a Remove Duplicates from Range function, in the workbook here, so that you can check the list it creates. This function below will remove the first duplicate in a range that you select.

Sub RemoveFirstDuplicates()

Dim rConstRange As Range, rFormRange As Range
Dim rAllRange As Range, rCell As Range
Dim iCount As Long
Dim strAdd As String

On Error Resume Next
Set rAllRange = Selection
If WorksheetFunction.CountA(rAllRange) < 2 Then
MsgBox “You selection is not valid”, vbInformation
On Error GoTo 0
Exit Sub
End If
Set rConstRange = rAllRange.SpecialCells(xlCellTypeConstants)
Set rFormRange = rAllRange.SpecialCells(xlCellTypeFormulas)
If Not rConstRange Is Nothing And Not rFormRange Is Nothing Then
Set rAllRange = Union(rConstRange, rFormRange)
ElseIf Not rConstRange Is Nothing Then
Set rAllRange = rConstRange
ElseIf Not rFormRange Is Nothing Then
Set rAllRange = rFormRange

Else
MsgBox “You selection is not valid”, vbInformation
On Error GoTo 0
Exit Sub
End If

Application.Calculation = xlCalculationManual

For Each rCell In rAllRange
strAdd = rCell.Address
strAdd = rAllRange.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

Application.Calculation = xlCalculationAutomatic
On Error GoTo 0

End Sub

This is another duplicate function - this one will count the duplicates and also highlight them in green (this was not included in download).

Sub CountNumberOfDuplicates()

On Error GoTo ENDER
Application.ScreenUpdating = False

If Selection.Columns.Count * Selection.Rows.Count = 1 Then
MsgBox “Select more then one cell.”, vbExclamation
Exit Sub
End If

SetColourIndex = 4

i = Selection.Cells.Count
n = 0
k = 0

For Each MyCell In Selection

CellCount = MyCell.Value
If MyCell.Value = “” Then
Else

If Application.WorksheetFunction.CountIf(Selection, CellCount) > 1 Then

k = k + 1
n = n + 1
MyCell.Interior.ColorIndex = SetColourIndex

End If

End If

Percentage = n / i * 100

Next

Application.StatusBar = False
Application.ScreenUpdating = True

MsgBox “Selection contains ” & k & ” duplicate values.”, vbInformation
Exit Sub
ENDER:
Application.StatusBar = False
Application.ScreenUpdating = True

End Sub

Related Posts

• Excel VB | XLA addin to display content of a folder
• Excel VB | XLA addin for auto cell colour format
• Excel VB | unique random numbers
• Excel VB | random password generator
• Excel VB | positive to negative & vice versa