Friday, September 9, 2011

VBA Function to return unique values



'The following function returns a unique list if passed an array of values

Public Function UniqueValues(SourceValues As Variant) As Variant
'Returns a variant containing the unique values contained within SourceValues
'If called from a worksheet array formula, returns either a row or column array, as needed.
Dim Items As New Collection
Dim i As Long, j As Long, m As Long, nCols As Long, nRows As Long, Row As Long
Dim rg As Range
Dim cel As Variant, Result() As Variant

On Error Resume Next
Set rg = Application.Caller
For Each cel In SourceValues
   If cel <> "" Then Items.Add CStr(cel), CStr(cel)
Next
If rg Is Nothing Then
Else
    nCols = rg.Columns.Count
    nRows = rg.Rows.Count
    m = Application.Max(nCols, nRows)
End If
On Error GoTo 0

i = Items.Count
ReDim Result(1 To i)
For Row = 1 To i
     j = 0
    If rg Is Nothing Then
        For Each cel In SourceValues
            If cel = Items(Row) Then j = j + 1
        Next
        Result(Row) = Items(Row) ' & "(" & j & ")"
    Else
        Result(Row) = Items(Row) '& "(" & Application.CountIf(SourceValues, Items(Row)) & ")"
    End If
Next Row

If m > i Then
    ReDim Preserve Result(1 To m)
    For Row = i + 1 To m
       Result(Row) = ""
    Next Row
End If

If nRows < 2 Then
    UniqueValues = Result
Else
    UniqueValues = Application.Transpose(Result)
End If

End Function

No comments:

Post a Comment