Count and store the unique values in a column

Question

Imagining I have the following column:

I want to build a code in VBA that returns first of all, the total of unique values, in this example: 3 (2008, 2009 and 2010), I also want to store these single values in an array (that's what I believe is best).

I've tried building a cycle that checks the last cell and compares results, but it's not enough obviously...

Not sure but sounds more like a homework question to me. Do you want an algorithm, or do you want someone to provide the VBA code for this? — Kris, Dec 16 '11 at 10:58
I'm somewhat past homework, this is a bigger project in which I have this very specific issue, I tried building a cycle that checks the lst cell and if it's different, it adds up to a counter and saves that value in a new variable, the problem is, and following my own example, when it gets to the last 2009 and checks the previous value (2010) it keeps 'incrementing' my counter despite there already being a 2009 value from before... I'm fine with the algorithm. — Jorg Ancrath, Dec 16 '11 at 11:04
We cannot say if the issue is in the algorithm or the coding. Either way that should be resolvable. — Kris, Dec 16 '11 at 11:07
Here is what I used to resolve the counting issue in Excel Formula: `=SUMPRODUCT((F7:F17<>"")/COUNTIF(F7:F17;F7:F17&""))` This gives me total of unique values, the problem is, I want this as VBA code... and I want the code to also record the values individually (so that I can use them later on a graph) — Jorg Ancrath, Dec 16 '11 at 11:13
[This](http://stackoverflow.com/questions/5382431/loading-an-array-with-only-unique-values) [is](http://stackoverflow.com/questions/4045767/extracting-unique-values-from-a-list) [SUCH](http://stackoverflow.com/questions/5382747/loading-an-array-with-only-unique-values-and-passing-to-them-to-a-function) [a](http://stackoverflow.com/questions/8533141/count-and-store-the-unique-values-in-a-column) [duplicate](http://stackoverflow.com/questions/3589744/how-to-return-unique-value-from-a-range-of-values-excel-vba)! — Jean-François Corbett, Dec 16 '11 at 13:06

score 4 · Accepted Answer · edited May 23 '17 at 12:07

4

If your unique data was in column A (say A1 to A5 in your example) then you can use a variant array with a dictionary to extract the uniques

The code below

creates a variant array X with your 5 values in column A
tests each item to see if it exists in a dictionary object objDic if not it is added to the dictionary, and to a second variant array Y
the final variant array Y is dumped to B1 extending as far as necessary (this array contains the uniques plus blanks at the end in place of dupes, it can be resized if necessary)

(Updated: added test to ignore blanks*)

    Sub GetUniques()
    Dim X
    Dim Y
    Dim objDic As Object
    Dim lngRow As Long
    Dim lngCnt As Long
    Set objDic = CreateObject("Scripting.Dictionary")
    X = Range([a1], Cells(Rows.Count, "A").End(xlUp)).Value2
    ReDim Y(1 To UBound(X, 1), 1 To 1)
    For lngRow = 1 To UBound(X, 1)
    If Len(X(lngRow, 1)) > 0 Then
      If objDic.exists(X(lngRow, 1)) = False Then
      lngCnt = lngCnt + 1
      Y(lngCnt, 1) = X(lngRow, 1)
      objDic.Add X(lngRow, 1), 1
      End If
    End If
    Next lngRow
    [b1].Resize(UBound(Y, 1), 1) = Y
    End Sub

enter image description here

version 2

Uses Join as per Simple VBA array join not working

Sub GetUniques2()
Dim X
Dim Y
Dim objDic As Object
Dim lngRow As Long
Dim lngCnt As Long
Set objDic = CreateObject("Scripting.Dictionary")
X = Range([a1], Cells(Rows.Count, "A").End(xlUp)).Value2
ReDim Y(1 To UBound(X, 1))
For lngRow = 1 To UBound(X, 1)
    If Len(X(lngRow, 1)) > 0 Then
        If objDic.exists(X(lngRow, 1)) = False Then
            lngCnt = lngCnt + 1
            Y(lngCnt) = X(lngRow, 1)
            objDic.Add X(lngRow, 1), 1
        End If
    End If
Next lngRow
ReDim Preserve Y(1 To lngCnt)
MsgBox Join(Y, ", ")
End Sub

edited May 23 '17 at 12:07

Community

1
1

answered Dec 16 '11 at 11:19

brettdj

54,857
16
114
177

Cheers man, will test it out. – Jorg Ancrath Dec 16 '11 at 11:21
@JoaoFerreira no probs, i added a test to exclude blanks above `If Len(X(lngRow, 1)) > 0 Then` cheers Dave – brettdj Dec 16 '11 at 11:28
I'm still new to vba, having no knowledge of dictionaries... is there a way to save those values into a single array instead of placing them in another column? – Jorg Ancrath Dec 16 '11 at 11:34
The values are stored in the variant array `Y`, You can use them from there in your code. Did you want a single string array intead? – brettdj Dec 16 '11 at 11:36
I'm still trying to understand all the logic behind this, but you've been very helpful. I'll make use of the Y array and see where it leads me. – Jorg Ancrath Dec 16 '11 at 11:39
I've added a second version that returns a single string of values separated by commas. cheers Dave – brettdj Dec 16 '11 at 11:41
Clear and efficient - I made a very slight edit for a better layout of your answer – JMax Dec 16 '11 at 11:56
Thx JMax, your formatting is always a value add, very nicely laid out – brettdj Dec 16 '11 at 12:30
+1 good stuff - I have noticed that the notation [a1] is the slowest possible way to refer to a cell, though (fastest is cells() and next is Range()). I imagine you might be writing it like that to fit one line in the answer, though, which is understandable. – Gaijinhunter Dec 17 '11 at 07:06
thx Issun. Yes, I prefer it for neatness but it is a touch slower. Useful info on this at http://support.microsoft.com/kb/104502/en-us – brettdj Dec 17 '11 at 07:10

score 0 · Answer 2 · answered Dec 16 '11 at 12:21

Check out the follwing function

Function UniqueItem(InputRange As Range, count As Long) As Variant
    Dim cl As Range, cUnique As New Collection, cValue As Variant
        Application.Volatile
        On Error Resume Next
        For Each cl In InputRange
            If cl.Formula <> "" Then
            cUnique.Add cl.Value, CStr(cl.Value)
            End If
        Next cl
        UniqueItem = ""
        If count = 1 Then
        UniqueItem = cUnique.count
        ElseIf count = 0 Then
        For i = 1 To cUnique.count
            If UniqueItem = "" Then
            UniqueItem = UniqueItem & cUnique(i)
            ElseIf UniqueItem <> "" Then
            UniqueItem = UniqueItem & ", " & cUnique(i)
            End If
        Next
        End If
        On Error GoTo 0
End Function

Following formula in a cell will return the unique items seperated by comma

=UniqueItem(A1:A7,0)

Following formula in a cell will return the count of unique items in the selected range

=UniqueItem(A1:A7,1)

How to use this function

Open excel file
Press Alt + F11
Create a new module and paste the code in it
Go back to the excel file and select the cell you want to have the result
Type formula as =UniqueItem(A1:A7,0) to return the unique items in the selected range. (You can select any range)
Type formula as =UniqueItem(A1:A7,1) to return the number of unique items in the selected range. (You can select any range)

Count and store the unique values in a column

2 Answers2

version 2