List Unique Items with VBA

When getting a lits 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:

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;

Option Explicit
Sub GetUniqueItems() 'Excel VBA to extract the unique items.
Dim UItem As Collection
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))
UItem.Add CStr(rng), CStr(rng)
Next
On Error GoTo 0
For i=1 To UItem.Count
Range("D" & i + 1)=UItem(i)
Next
'Sort the Range
Range("D2", Range("D" & Rows.Count).End(xlUp)).Sort Range("D2"), 1
End Sub

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.

Option Explicit

Sub GetUnique() 'VBA to extract unique items (with the dictionary)
Dim r As Range
Dim rng As Range
Dim ar As Variant
Dim var As Variant

With Sheet1.Range("A9").CurrentRegion
With Createobject("scripting.dictionary")
For Each rng In Range("A10", Range("A" & Rows.Count).End(xlUp))
var=.Item(rng.Value)
Next
ar=.Keys
End With End With
Range("E10").Resize(UBound(ar) + 1)=Application.Transpose(ar)
End Sub

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.

Sub UniqueVals()
Dim i As Variant
Dim j As Variant

j = Application.Transpose(Range("A1", Range("A" & Rows.Count).End(xlUp)))

With CreateObject("Scripting.Dictionary")
For Each i In j
.Item(i) = i
Next
Cells(1, 2).Resize(.Count) = Application.Transpose(.Keys)
End With
End Sub

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.