Excel: Remove Duplicates in Excel

Got any Excel/VBA Questions? Free Excel Help

Remove Duplicates With Advanced Filter

This method of removing duplicates uses Excel's Advanced Filter and is about the fastest method. This example acts on data in Column "A".

Sub RemoveDupes()



	'Add extra Column, "A" becomes "B"

	Columns(1).EntireColumn.Insert

	

	'Filter out duplicates and copy unique list to "A"

	Range("B1", Range("B65536").End(xlUp)).AdvancedFilter _

		Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True



	'Add extra Column, "B" becomes "A"

	Columns(2).EntireColumn.Delete



End Sub

Note how an extra Column is inserted so that Column "A" becomes Column "B", it is then deleted so all returns to normal.

Remove Duplicates From Any Range Selection

This method of removing duplicates will work on the selected data.

Sub KillDupes()

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