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