Remove ALL duplicates from column A in Excel - vba

Question

I am looking for a macro that can remove ALL duplicates from column A.
Input:
John
Jimmy
Brenda
Brenda
Tom
Tom
Todd
Output:
John
Jimmy
Todd
I am working with a large set of data, and Excel isn't cooperating. Can't seem to find a solution online that works.
Thanks!

Answer 1

When you want to de-duplicate your list, that is make sure you only have ONE item left of each, you can to this:
In Excel 2007 and above you have a Remove Duplicates in the Data menu, which will do it for you.
In Excel 2003 and earlier you can use the Advanced Filter in the Data/Filter menu:
And then copy-paste the results in a new sheet.
You can see the full procedure here.
Otherwise it is a tedious macro to write (a recursive loop to check if the value exist in the set). It can be done, but do you really need it?
But if you want to actually delete all entries that are the same then using #Eoins's macro will do the job, but a bit modified as follows:
Option Explicit
Sub DeleteDuplicate()
Dim x, Y As Long
Dim LastRow As Long
Dim myCell As String
LastRow = Range("A1").SpecialCells(xlLastCell).Row
For x = LastRow To 1 Step -1
myCell = Range("A" & x).Text
If Application.WorksheetFunction.CountIf(Range("A1:A" & x), myCell) > 1 Then
For Y = x To 1 Step -1
If Range("A" & Y).Text = myCell Then
Range("A" & Y).EntireRow.Delete
End If
Next Y
End If
Next x
End Sub

Answer 2

As your request is for a macro, please try this:
Excel 2007+
ActiveSheet.Range("A:A").RemoveDuplicates
Here is your option for Excel 2003
Option Explicit
Sub DeletDuplicate()
Dim x As Long
Dim LastRow As Long
LastRow = Range("A65536").End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
Range("A" & x).EntireRow.Delete
End If
Next x
End Sub

Answer 3

Here is a recursive loop just in case you want it :)
It's actually 2 procedures, the first one sorts the list and the second one removes duplicates
'----------------------------------------------------------------------
'--SORT A 1D ARRAY NUMERICALLY-ALPHABETICALLY(TAKEN FROM StackOverflow)
'----------------------------------------------------------------------
Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
Dim pivot As Variant
Dim tmpSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long
tmpLow = inLow
tmpHi = inHi
pivot = vArray((inLow + inHi) \ 2)
While (tmpLow <= tmpHi)
While (vArray(tmpLow) < pivot And tmpLow < inHi)
tmpLow = tmpLow + 1
Wend
While (pivot < vArray(tmpHi) And tmpHi > inLow)
tmpHi = tmpHi - 1
Wend
If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Wend
If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub
'---------------------------------------
'--REMOVE DUPLICATES AND BLANKS FROM SORTED 1D ARRAY
'---------------------------------------
Public Function RemoveDuplicatesBlanks_1DSorted(Arr As Variant) As Variant
Dim i As Long, iMin As Long, iMax As Long, Cnt As Long
Dim TArr As Variant, TArr2() As Variant
TArr = Arr
iMin = LBound(TArr)
iMax = UBound(TArr)
i = iMin
Do While i <= iMax
If TArr(i) = vbNullString Then
Cnt = Cnt + 1
ElseIf i < iMax Then
If TArr(i) = TArr(i + 1) Then
TArr(i) = Empty
Cnt = Cnt + 1
End If
End If
i = i + 1
Loop
ReDim TArr2(iMin To (iMax - Cnt))
Cnt = iMin
For i = iMin To iMax
If Not TArr(i) = vbNullString Then
TArr2(Cnt) = TArr(i)
Cnt = Cnt + 1
End If
Next i
RemoveDuplicatesBlanks_1DSorted = TArr2
End Function
The way these are setup you would use them like this.....
QuickSort MyArray, LBound(MyArray), UBOUND(MyArray)
MyArray = RemoveDuplicatesBlanks_1DSorted(MyArray)
These work only for 1 dimensional arrays, I also have them for 2 dimensional arrays if you need those.
I've used these many times and they are very fast, a lot faster than most methods so if you have large lists its worth using these methods.
----ADDITIONAL INFORMATION----
The ExtractArrayColumn function is beneath this code....This code here is how you would use all these procedures
Private sub RemoveDuplicate()
Dim MyRangeArray As Variant, MyArray As Variant
MyRangeArray = Range("A1:A100").Value
MyArray = ExtractArrayColumn(MyRAngeArray,1)
QuickSort MyArray, LBound(MyArray), UBOUND(MyArray)
MyArray = RemoveDuplicatesBlanks_1DSorted(MyArray)
Range("A1:A100").Value = MyArray
End Sub
Public Function ExtractArrayColumn(Array_Obj As Variant, Column_Index As Long) As Variant
Dim TArr() As Variant
Dim L1 As Long, H1 As Long
Dim i As Long
L1 = LBound(Array_Obj, 1)
H1 = UBound(Array_Obj, 1)
ReDim TArr(L1 To H1)
For i = L1 To H1
TArr(i) = Array_Obj(i, Column_Index)
Next i
ExtractArrayColumn = TArr
End Function