List Unique Items with VBA
When getting a list of unique items in Excel I have always sided with using the Advanced Filter with VBA. I have favoured the Advanced Filter for its simplicity and speed. The following however, involves stepping into the world of collections and this is important as your VBA knowledge grows. Collections have a great deal of flexibility, From Microsoft;
Once you have created a collection, you can do any one of the following:
- Add an element that uses the Add Method.
- Remove an element that uses the Remove Method.
- Remove all elements that use the Clear Method.
- Find out how many elements the collection contains with the Count Property.
- Check whether a specific element is present with the Contains Method.
- Return a specific element from the collection with the Item Property.
- Iterate through the complete collection with the For Each...Next Statement (Visual Basic).
Back to our procedure. I am going to get all of the items in a list which are unique and then sort that list in Ascending Order. The following is the Excel VBA code to achieve this;
Sub GetUniqueItems() 'Excel VBA to extract the unique items.
Dim UV As New Collection
Dim rng As Range
Dim i As Long
Set UItem= New Collection
On Error Resume Next
For Each rng In Range("A2", Range("A" & Rows.Count).End(xlUp))
On Error GoTo 0
For i=1 To UItem.Count
'Sort the Range
Range("D2", Range("D" & Rows.Count).End(xlUp)).Sort Range("D2"), 1
Unique Items with the Scripting Dictionary
Another way to do this is to use the Scripting Dictionary to extract the unique items in a list. The following procedure will add all of the unique items from A10 to the bottom of Coumn A in E10. Like the above VBA procedure it is very fast using vba's scripting dictionary.
Sub GetUnique() 'VBA to extract unique items (with the dictionary)
Dim rng As Range
Dim ar As Variant
Dim var As Variant
With Sheet1.Range("A9").CurrentRegion
ar=.Keys
Range("E10").Resize(UBound(ar) + 1)=Application.Transpose(ar)
In the interest of continual improvement I will leave the above code however I got involved in a post on Ozgrid recently and managed another crack at this unique list problem. The following is the most efficient coding I could come up with.
Dim i As Variant
Dim j As Variant
j = Application.Transpose(Range("A1", Range("A" & Rows.Count).End(xlUp)))
Cells(1, 2).Resize(.Count) = Application.Transpose(.Keys)
The following is a working Excel example of the above. The ranges are changed only slightly but the theory remains the same. The Excel file displays both vba procedures.
