Case sensitive unique list

[Smurfette18]

Hello,

On another post to this group I found the following code, which creates
a case-sensitive unique list of items:

'Requires project reference to the "Microsoft Scripting Runtime"
Sub Test()
Dim x As Scripting.Dictionary
Dim Rng As Range
Dim iVal As Range


Set x = New Scripting.Dictionary
Set Rng = Range("A1:A5")


On Error Resume Next
For Each iVal In Rng
x.Add key:=iVal.Text, Item:=iVal
Next
On Error GoTo 0
Range(Cells(1, 2), Cells(1, x.Count + 1)).Value = x.Keys


Set Rng = Nothing
Set iVal = Nothing
Set x = Nothing
End Sub

My question is, does anyone know how to output this list vertically
instead of horizontally? I know that I can transpose it afterward but
that is not ideal. I tried outputting to a vertical range of equal
number of cells but was left with the first entry in the list repeated
in all of the cells.

Any ideas???

 

[NickHK]

If you Transpose, you need to resize in row then, not the column. This works
for me :

Range(Cells(1, 3), Cells(x.Count, 3)).Value = Application.Transpose(x.Keys)

NickHK

 

[Alan Beban]

The following function will produce a one-based, case-sensitive,
vertical unique list that omit blanks, all by default. By specifying
the appropriate parameters you can produce a unique list that is
0-based, or horizontal, or not case sensitive, or does not omit the blank.

If the input array is more than 5460 elements and you are using a
version of Excel prior to Version 9, the function depends on another
function, ArrayTranspose, that I will post if you post back requesting it.

Alan Beban

Function ArrayUniques(InputArray, _
Optional MatchCase As Boolean = True, _
Optional Base_Orient As String = "1vert", _
Optional OmitBlanks As Boolean = True)
'THIS PROCEDURE REQUIRES A PROJECT REFERENCE
'TO "MICROSOFT SCRIPTING RUNTIME".
'The function returns an array of unique
'values from an array or range. By default
'it returns a 1-based vertical array; for
'other results enter "0horiz", "1horiz" or
'"0vert" as the third argument. By default,
'the function is case-sensitive; i.e., e.g.,
'"red" and "Red" are treated as two separate
'unique values; to avoid case-sensitivity,
'enter False as the second argument.

'Declare the variables
Dim arr, arr2
Dim i As Long, p As Object, q As String
Dim Elem, x As Dictionary
Dim CalledDirectFromWorksheet As Boolean

'For later use in selecting cells for worksheet output
CalledDirectFromWorksheet = False
If TypeOf Application.Caller Is Range Then
Set p = Application.Caller
q = p.Address
iRows = Range(q).Rows.Count
iCols = Range(q).Columns.Count
If InStr(1, p.FormulaArray, "ArrayUniques") = 2 _
Or InStr(1, p.FormulaArray, "arrayuniques") = 2 _
Or InStr(1, p.FormulaArray, "ARRAYUNIQUES") = 2 Then
CalledDirectFromWorksheet = True
End If
End If

'Convert an input range to a VBA array
arr = InputArray

'Load the unique elements into a Dictionary Object
Set x = New Dictionary
x.CompareMode = Abs(Not MatchCase) '<--Case-sensitivity
On Error Resume Next
For Each Elem In arr
x.Add Item:=Elem, Key:=CStr(Elem)
Next
If OmitBlanks Then x.Remove ("")
On Error GoTo 0

'Load a 0-based horizontal array with the unique
'elements from the Dictionary Object
arr2 = x.Items

'This provides appropriate base and orientation
'of the output array
Select Case Base_Orient
Case "0horiz"
arr2 = arr2
Case "1horiz"
ReDim Preserve arr2(1 To UBound(arr2) + 1)
Case "0vert"
If x.Count < 5461 Or Application.Version > 9 Then
arr2 = Application.Transpose(arr2)
Else
arr2 = ArrayTranspose(arr2)
End If
Case "1vert"
ReDim Preserve arr2(1 To UBound(arr2) + 1)
If x.Count < 5461 Or Application.Version > 9 Then
arr2 = Application.Transpose(arr2)
Else
arr2 = ArrayTranspose(arr2)
End If
End Select

'Assure that enough cells are selected to accommodate output
If CalledDirectFromWorksheet Then
If Range(Application.Caller.Address).Count < x.Count Then
ArrayUniques = "Select a range of at least " & x.Count & " cells"
Exit Function
End If
End If

ArrayUniques = arr2

End Function