VBA: adding distinct values in a range to a new range

Question

I have an unsorted list of names in Sheet1, Column A. Many of these names appear more than once in the list.

On Sheet2 Column A I want an alphabetically sorted list of the names with no duplicate values.

What is the optimal method of achieving this using VBA?

Methods I have seen so far include:

Making a collection with CStr(name) as the key, looping through the range and trying to add each name; if there is an error it is not unique, ignore it, else expand the range by 1 cell and add the name
Same as (1), except ignore about the errors. When the loop is complete, only unique values will be in the collection: THEN add the whole collection to the range
Using the match worksheet function on the range: if no match, expand the range by one cell and add the name
Maybe some simulation of the "remove duplicates" button on the data tab? (haven't looked into this)

I would go in with Option 4. 1) Record a macro 2) Copy Col A to 2nd sheet 3) Select Col A and press the remove duplicates button under the data tab if you are using Excel 2007 4) Sort the data :) Give it a try and if you get stuck then post back :) — Siddharth Rout, May 09 '12 at 22:24
Questions like this have been asked so many times on SO... Have a look at previous answers ([here for example](http://stackoverflow.com/a/5896692/119775)), try something, see if it works, get back to us with any problems. [This](http://meta.stackexchange.com/a/5235/164088) and [this](http://stackoverflow.com/questions/how-to-ask) would be useful reading for you as well. — Jean-François Corbett, May 10 '12 at 06:20

Brad · Answer 1 · 2012-05-10T04:05:17.810

I really like the dictionary object in VBA. It's not natively available but it's very capable. You need to add a reference to Microsoft Scripting Runtime then you can do something like this:

Dim dic As Dictionary
Set dic = New Dictionary
Dim srcRng As Range
Dim lastRow As Integer

Dim ws As Worksheet
Set ws = Sheets("Sheet1")

lastRow = ws.Cells(1, 1).End(xlDown).Row
Set srcRng = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 1))

Dim cell As Range

For Each cell In srcRng
    If Not dic.Exists(cell.Value) Then
        dic.Add cell.Value, cell.Value   'key, value
    End If
Next cell

Set ws = Sheets("Sheet2")    

Dim destRow As Integer
destRow = 1
Dim entry As Variant

'the Transpose function is essential otherwise the first key is repeated in the vertically oriented range
ws.Range(ws.Cells(destRow, 1), ws.Cells(dic.Count, 1)) = Application.Transpose(dic.Items)

You can transpose the array of dictionary keys to the range in one step using dic.keys. Try it out :) — Gaijinhunter, May 10 '12 at 02:32
oh interesting. I like it. I updated my answer to show this change! — Brad, May 10 '12 at 04:02

score 0 · Accepted Answer · answered May 10 '12 at 07:33

As you suggested, a dictionary of some sort is the key. I would use a Collection - it is builtin (in contrary to Scripting.Dictionary) and does the job.

If by "optimal" you mean "fast", the second trick is to not access each cell individually. Instead use a buffer. The below code will be fast even with thousands of rows of input.

Code:

' src is the range to scan. It must be a single rectangular range (no multiselect).
' dst gives the offset where to paste. Should be a single cell.
' Pasted values will have shape N rows x 1 column, with unknown N.
' src and dst can be in different Worksheets or Workbooks.
Public Sub unique(src As Range, dst As Range)
    Dim cl As Collection
    Dim buf_in() As Variant
    Dim buf_out() As Variant
    Dim val As Variant
    Dim i As Long

    ' It is good practice to catch special cases.
    If src.Cells.Count = 1 Then
        dst.Value = src.Value   ' ...which is not an array for a single cell
        Exit Sub
    End If
    ' read all values at once
    buf_in = src.Value
    Set cl = New Collection
    ' Skip all already-present or invalid values
    On Error Resume Next
    For Each val In buf_in
        cl.Add val, CStr(val)
    Next
    On Error GoTo 0

    ' transfer into output buffer
    ReDim buf_out(1 To cl.Count, 1 To 1)
    For i = 1 To cl.Count
        buf_out(i, 1) = cl(i)
    Next

    ' write all values at once
    dst.Resize(cl.Count, 1).Value = buf_out

End Sub

VBA: adding distinct values in a range to a new range

2 Answers2