Sub RemoveDups3(R As Range, Cols As Variant, Hdrs As Boolean)
'remove duplicate entries from range R, enter Cols as array to indicate which fields are compared, Hdrs is true if R has Headers
Dim d As Object, Vin As Variant, i As Long, c As Variant, x As Variant, ct As Long
Dim dRws As Long, Srt() As Variant
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
R.Columns(R.Columns.Count).Offset(0, 1).EntireColumn.Insert
Set d = CreateObject("Scripting.Dictionary")
Vin = R.Value
ReDim Srt(1 To R.Rows.Count, 1 To 1)
If Hdrs Then
n = 2
Else
n = 1
End If
For i = n To UBound(Vin, 1)
x = vbNullString
For Each c In Cols
x = Join(Array(x, Vin(i, c)), Chr(2))
Next c
If Not d.exists(x) Then
ct = ct + 1
d.Add x, ct
Srt(i, 1) = ""
Else
dRws = dRws + 1
Srt(i, 1) = 1
R.Rows(i).Cells(1, R.Columns.Count + 1).Value = 1
End If
Next i
If dRws > 0 Then
R.Columns(R.Columns.Count).Offset(0, 1).Value = Srt
R.Rows(1).Cells(1, R.Columns.Count + 1).Sort key1:=R.Rows(1).Cells(1, R.Columns.Count + 1), order1:=xlAscending
R.Rows(1).Resize(dRws).Delete shift:=xlUp
R.Columns(R.Columns.Count).Offset(0, 1).EntireColumn.Delete
R.Rows(R.Rows.Count).Offset(1, 0).Resize(dRws).Insert shift:=xlDown
Select Case n
Case 1: MsgBox UBound(Vin, 1) - ct & " duplicates removed"
Case 2: MsgBox UBound(Vin, 1) - 1 - ct & " duplicates removed"
End Select
Else
MsgBox "No dupicate entries found in range: " & R.Address(0, 0)
End If
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Sub test3()
Call RemoveDups(Range("A1").CurrentRegion, Array(1, 2, 4), False)
End Sub
