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???

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

"Smurfette18" wrote in message
ups.com...
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???

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


Smurfette18 wrote:
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???