Function UNIQUE(array_range As Variant, Optional by_col As Boolean = False, Optional exactly_once As Boolean = False) As Variant ' Excel 2021
'
Dim ArrayColumn As Long, ArrayRow As Long
Dim ArrayDimensionFoundValue As Long, MaximumDimension As Long
Dim dict As Object
Dim ConcatString As String
Dim key As Variant, SplitKeyArray As Variant
Dim OutputArray As Variant, TempArray As Variant
'
Set dict = CreateObject("Scripting.Dictionary") ' Establish the dictionary
'
If TypeName(array_range) = "Range" Then ' If array_range is a range instead of an array then ...
array_range = array_range.value2 ' Convert/Save the array_range values to 2D array array_range
Else ' Else ...
'
' Get # of dimensions of a passed array
On Error Resume Next ' If error occurs in next few lines, ignore it & proceed to next line
Do Until ArrayDimensionFoundValue = 999 ' Loop until ArrayDimensionFoundValue = 999
MaximumDimension = MaximumDimension + 1 ' Increment MaximumDimension
ArrayDimensionFoundValue = 999 ' Set ArrayDimensionFoundValue = 999
ArrayDimensionFoundValue = UBound(array_range, MaximumDimension) ' Test to see if the incremented dimension in array_range exists
Loop ' Loop back
On Error GoTo 0 ' Return error handling back to Excel
'
MaximumDimension = MaximumDimension - 1 ' Correct MaximumDimension to the correct dimension value of array_range
End If
'
If MaximumDimension = 1 Then ' If array_range is a 1D array then ...
ReDim TempArray(1 To 1, 1 To UBound(array_range)) ' Create 2D TempArray to store the values from the 1D array_range
'
For ArrayColumn = 1 To UBound(array_range) ' Loop through columns of array_range
TempArray(1, ArrayColumn) = array_range(ArrayColumn) ' Save the values from array_range to TempArray
Next ' Loop back
'
array_range = TempArray ' Save TempArray back to array_range, this will make array_range a 2D array
End If
'-------------------------------------------------------------------------------------------------------------------
If by_col = False Then '
'
' by_col = False ... Get all unique rows
For ArrayRow = LBound(array_range, 1) To UBound(array_range, 1) ' Loop through rows of array_range
For ArrayColumn = LBound(array_range, 2) To UBound(array_range, 2) ' Loop through columns of array_range
If ConcatString <> vbNullString Then ' If ConcatString is not blank then ...
ConcatString = ConcatString & Chr(2) & array_range(ArrayRow, ArrayColumn) ' Append delimiter & the value from array_range to ConcatString
Else ' Else ...
ConcatString = array_range(ArrayRow, ArrayColumn) ' Save the value from array_range to ConcatString
End If
Next ' Loop back
'
If Not dict.exists(ConcatString) Then ' If ConcatString is unique to what has been saved to the dictionary then ...
dict.Add ConcatString, 1 ' Add it to the dictionary along with a counter value of 1
Else ' Else ...
dict(ConcatString) = dict(ConcatString) + 1 ' Increment the counter value for that ConcatString
End If
'
ConcatString = vbNullString ' Clear ConcatString
Next ' Loop back
'
ReDim OutputArray(1 To dict.Count, 1 To UBound(array_range, 2)) ' Set OutputArray to the proper row & column size needed
'
ArrayRow = 0 ' Reset ArrayRow
'
For Each key In dict.keys ' Loop through the keys in the dictionary
If exactly_once = False Then '
SplitKeyArray = Split(key, Chr(2)) ' Split ConcatString by delimiter into 1D Zero based SplitKeyArray
'
ArrayRow = ArrayRow + 1 ' Increment ArrayRow
'
For ArrayColumn = 1 To UBound(SplitKeyArray) + 1 ' Loop through the columns of SplitKeyArray
OutputArray(ArrayRow, ArrayColumn) = SplitKeyArray(ArrayColumn - 1) ' Save each column value from SplitKeyArray into OutputArray
Next ' Loop back
Else ' Else ...
If dict(key) = 1 Then ' If the ConcatString was only seen 1 time then ...
SplitKeyArray = Split(key, Chr(2)) ' Split ConcatString by delimiter into 1D Zero based SplitKeyArray
'
ArrayRow = ArrayRow + 1 ' Increment ArrayRow
'
For ArrayColumn = 1 To UBound(SplitKeyArray) + 1 ' Loop through the columns of SplitKeyArray
OutputArray(ArrayRow, ArrayColumn) = SplitKeyArray(ArrayColumn - 1) ' Save each column value from SplitKeyArray into OutputArray
Next ' Loop back
End If
End If
Next ' Loop back
Else ' Else ...
'-------------------------------------------------------------------------------------------------------------------
'
' by_col = True ... Get all unique columns
For ArrayColumn = LBound(array_range, 2) To UBound(array_range, 2) ' Loop through columns of array_range
For ArrayRow = LBound(array_range, 1) To UBound(array_range, 1) ' Loop through rows of array_range
If ConcatString <> vbNullString Then ' If ConcatString is not blank then ...
ConcatString = ConcatString & Chr(2) & array_range(ArrayRow, ArrayColumn) ' Append delimiter & the value from array_range to ConcatString
Else ' Else ...
ConcatString = array_range(ArrayRow, ArrayColumn) ' Save the value from array_range to ConcatString
End If
Next ' Loop back
'
If Not dict.exists(ConcatString) Then ' If ConcatString is unique to what has been saved to the dictionary then ...
dict.Add ConcatString, 1 ' Add it to the dictionary along with a counter value of 1
Else ' Else ...
dict(ConcatString) = dict(ConcatString) + 1 ' Increment the counter value for that ConcatString
End If
'
ConcatString = vbNullString ' Clear ConcatString
Next ' Loop back
'
ReDim OutputArray(1 To UBound(array_range, 1), 1 To dict.Count) ' Set OutputArray to the proper row & column size needed
'
ArrayColumn = 0 ' Reset ArrayColumn
'
For Each key In dict.keys ' Loop through the keys in the dictionary
If exactly_once = False Then '
SplitKeyArray = Split(key, Chr(2)) ' Split ConcatString by delimiter into 1D Zero based SplitKeyArray
'
ArrayColumn = ArrayColumn + 1 ' Increment ArrayColumn
'
For ArrayRow = 1 To UBound(SplitKeyArray) + 1 ' Loop through the rows of SplitKeyArray
OutputArray(ArrayRow, ArrayColumn) = SplitKeyArray(ArrayRow - 1) ' Save each row value from SplitKeyArray into OutputArray
Next ' Loop back
Else ' Else ...
If dict(key) = 1 Then ' If the ConcatString was only seen 1 time then ...
SplitKeyArray = Split(key, Chr(2)) ' Split ConcatString by delimiter into 1D Zero based SplitKeyArray
'
ArrayColumn = ArrayColumn + 1 ' Increment ArrayColumn
'
For ArrayRow = 1 To UBound(SplitKeyArray) + 1 ' Loop through the rows of SplitKeyArray
OutputArray(ArrayRow, ArrayColumn) = SplitKeyArray(ArrayRow - 1) ' Save each row value from SplitKeyArray into OutputArray
Next ' Loop back
End If
End If
Next ' Loop back
End If
'
UNIQUE = OutputArray '
End Function
