vba copy cell values filters out numerical data

Question

I have an issue. I am trying to copy all unique values (numerical and alphanumerical) from a dynamic sheet to another. I found a great script on a forum, which works quickly and have adapted this. The issue is that it seems to filter out all numerical values and for the life of me I cannot see why!?! Can you help?

    Sub GetUniqueItems()
    Dim vData As Variant, n&, lLastRow&, sMsg$

    lLastRow = Worksheets(Worksheets("Summary").Range("A1").Value)._
    Cells(Rows.Count, "H").End(xlUp).Row
    If lLastRow = 1 Then Exit Sub '//no data

    vData = Worksheets(Worksheets("Summary").Range("A1").Value)._
    Range("H2:H" & lLastRow)
    Dim oColl As New Collection
    On Error Resume Next
    For n = LBound(vData) To UBound(vData)
    oColl.Add vData(n, 1), vData(n, 1)
    Next 'n

    For n = 1 To oColl.Count
    sMsg = oColl(n)
    Sheets("Summary").Cells(n + 3, 1).Value = Mid$(sMsg, 1)
    Next 'n

    End Sub

Answer 1

The key for a Collection item needs to be a string. So change this line:

oColl.Add vData(n, 1), vData(n, 1)

to this:

oColl.Add vData(n, 1), CStr(vData(n, 1))

Also, although you need the On Error Resume Next so the code will skip over any attempts to add duplicates to the collection, you should only use it for that one line. Otherwise you risk masking other errors in your code. (The reason your code didn't have a runtime error was because the On Error Resume Next, in addition to doing it's job of bypassing duplicates, was also skipping over any Adds with numeric Keys.

For that reason, I moved the line to just before the oColl.Add and added On Error Goto 0 just after:

Here's the full routine:

Sub GetUniqueItems()
Dim vData As Variant, n&, lLastRow&, sMsg$
Dim oColl As Collection

lLastRow = Worksheets(Worksheets("Summary").Range("A1").Value).Cells(Rows.Count, "H").End(xlUp).Row
If lLastRow = 1 Then Exit Sub

vData = Worksheets(Worksheets("Summary").Range("A1").Value).Range("H2:H" & lLastRow)
Set oColl = New Collection
For n = LBound(vData) To UBound(vData)
    On Error Resume Next
    oColl.Add vData(n, 1), CStr(vData(n, 1))
    On Error GoTo 0
Next n

For n = 1 To oColl.Count
    sMsg = oColl(n)
    Sheets("Summary").Cells(n + 3, 1).Value = Mid$(sMsg, 1)
Next n
End Sub

One last thing: you want to avoid statements like Dim oColl As New Collection, and instead declare and set it in two steps as I did. For the reason see the Chip Pearson page and scroll down to "Don't Use Auto-Instancing Object Variables."

Answer 2

I am showing the code below as it may be of interest to the OP, or others, and is an efficient way to obtain a unique list from a column of data.

In Excel 2007 or above we can copy the column and make use of the Remove Duplicates feature to obtain our unique list.

Sub CreateUniqueList()
    Dim lLastRow As Long
    Dim wsSum As Worksheet
    Dim rng As Range

    Set wsSum = Worksheets("Summary")
    lLastRow = wsSum.Cells(Rows.Count, "H").End(xlUp).Row
    If lLastRow = 1 Then Exit Sub

    wsSum.Range("H2:H" & lLastRow).Copy wsSum.Cells(4, 1)
    wsSum.Range(wsSum.Cells(4, 1), wsSum.Cells(4 + lLastRow - 2, 1)). _
        RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

The only slight disadvantage is that we first have to copy the entire column, but this is minor in comparison to the performance increase for a large set of data.