'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
Comments
Post a Comment