How do I get a list of unique values from a range in Excel VBA?

Question

I would like to get a list of unique values in a range using VBA. Most examples in Google talk about getting a list of unique values in a column using VBA.

I am not sure how to change it to get a list of value in a range.

For example,

Currency    Name 1  Name 2  Name 3  Name 4  Name 5
SGD BGN DBS         
PHP PDSS                
KRW BGN             
CNY CBBT    BGN         
IDA INPC                

My array should look like:

BGN, DBS, PDSS, CBBT and INPC.

How do I do it? Need some guidance.

Answer 1

I would use a simple VBA-Collection and add items with key. The key would be the item itself and because there can't be duplicit keys the collection will contain unique values.

Note: Because adding duplicit key to collection raises error wrap the call to collection-add into a on-error-resume-next.

The function GetUniqueValues has source-range-values as parameter and retuns VBA-Collection of unique source-range-values. In the main method the function is called and the result is printed into Output-Window. HTH.

Sample source range looked like this:

Option Explicit

Sub main()
    Dim uniques As Collection
    Dim source As Range

    Set source = ActiveSheet.Range("A2:F6")
    Set uniques = GetUniqueValues(source.Value)

    Dim it
    For Each it In uniques
        Debug.Print it
    Next
End Sub

Public Function GetUniqueValues(ByVal values As Variant) As Collection
    Dim result As Collection
    Dim cellValue As Variant
    Dim cellValueTrimmed As String

    Set result = New Collection
    Set GetUniqueValues = result

    On Error Resume Next

    For Each cellValue In values
        cellValueTrimmed = Trim(cellValue)
        If cellValueTrimmed = "" Then GoTo NextValue
        result.Add cellValueTrimmed, cellValueTrimmed
NextValue:
    Next cellValue

    On Error GoTo 0
End Function

Output

SGD
PHP
KRW
CNY
IDA
BGN
PDSS
CBBT
INPC
DBS
a

---

In case when the source range consists of areas get the values of all the areas first.

Public Function GetSourceValues(ByVal sourceRange As Range) As Collection
    Dim vals As VBA.Collection
    Dim area As Range
    Dim val As Variant
    Set vals = New VBA.Collection
    For Each area In sourceRange.Areas
        For Each val In area.Value
            If val <> "" Then _
                vals.Add val
        Next val
    Next area
    Set GetSourceValues = vals
End Function

Source type is now Collection but then all works the same:

Dim uniques As Collection
Dim source As Collection

Set source = GetSourceValues(ActiveSheet.Range("A2:F6").SpecialCells(xlCellTypeVisible))
Set uniques = GetUniqueValues(source)

Answer 2

If you have Office 365 then you can use Application.WorksheetFunction.Unique function to quickly return an array of unique values.

Example:

    Dim Uniques As Variant
    Uniques = Application.WorksheetFunction.Unique(your_source_range)

Then to copy the unique values to another column, for example:

your_destination_range.Value = Uniques

Answer 3

Loop through the range, check if the value is in the array, if not add it to the array.

Sub test()
Dim Values() As Variant
Values = GetUniqueVals(Selection)
Dim i As Integer
    For i = LBound(Values) To UBound(Values)
        Debug.Print (Values(i))
    Next

End Sub

Function GetUniqueVals(ByRef Data As Range) As Variant()
    Dim cell As Range
    Dim uniqueValues() As Variant
    ReDim uniqueValues(0)

    For Each cell In Data
        If Not IsEmpty(cell) Then
            If Not InArray(uniqueValues, cell.Value) Then
                If IsEmpty(uniqueValues(LBound(uniqueValues))) Then
                    uniqueValues(LBound(uniqueValues)) = cell.Value
                Else
                    ReDim Preserve uniqueValues(UBound(uniqueValues) + 1)
                    uniqueValues(UBound(uniqueValues)) = cell.Value
                End If
            End If
        End If
    Next
    GetUniqueVals = uniqueValues
End Function

Function InArray(ByRef SearchWithin() As Variant, ByVal SearchFor As Variant) As Boolean
    Dim i As Integer
    Dim matched As Boolean 'Default value of boolean is false, we make true only if we find a match

    For i = LBound(SearchWithin) To UBound(SearchWithin)
        If SearchWithin(i) = SearchFor Then matched = True
    Next

    InArray = matched
End Function

Answer 4

As of Excel 365, they have introduced the UNIQUE() Worksheet Function.

From Microsoft:

The UNIQUE function returns a list of unique values in a list or range.

=UNIQUE(Range,[by_col],[exactly_once])

This formula will output the unique values in multiple cells:

So entering the formula in A3, I wouldn't be able to use B3, or C3 as they contain some of the results.

So, for VBA you can just use Evaluate():

Dim uniques as Variant
uniques = Evalute("Unique(" & rng.Address & ",TRUE,FALSE)")

Which returns them in an array (Note: The index starts at 1 here, not 0).

Answer 5

I have a similar need and came up with the following VBA functions I can use in VBA or the cells. The advantage is you can go nuts adding ranges in the argument list (=DistinctWS(";", E4:E42, G4:G12)) and it works in legacy Excel. Modify as needed.

Public Function DistinctWS(Delimiter As String, ParamArray r()) As String
    '---create a CSV string that is composed of the distinct values in the ranges
    Dim Rng As Range: Dim C As String:
    Dim i As Integer: Dim j As Integer: Dim st() As String: Dim q As Integer
    For Each rRng In r
        Set Rng = rRng
        For i = 1 To Rng.Areas.count
            For j = 1 To Rng.Areas(i).Cells.count
                C = Rng.Areas(i).Cells(j).Value
                If q = 0 Then
                    ReDim Preserve st(q) As String: st(q) = C: q = q + 1
                    DistinctWS = C
                ElseIf Not IsInArray(C, st) Then
                    ReDim Preserve st(q) As String: st(q) = C: q = q + 1
                    DistinctWS = DistinctWS & Delimiter & C
                End If
            Next j
        Next i
    Next
End Function

Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    Dim i As Integer: '   IsInArray = False is default
    For i = LBound(arr) To UBound(arr)
        If arr(i) = stringToBeFound Then
            IsInArray = True: Exit Function
        End If
    Next i
End Function