I have an app in which a certain subset of data can actually be used. I
have no problem in determining which data has in fact been used, but I
want a VBA routine that can look through a range (in which the used
data appears) and copy them to consecutive cells (with no blanks in
between). An example would be an itemized list, where only the used
item appear.
Eg. Initial column data Wanted data presentation
Blank Test 1
Test 1 Test 2
Blank Test 3
Blank
Test 2
Test 3
Blank
Hope this is clear. Any help would be appriciated.
Simon
The following will work if the number of unique values is less than 5462
or you are using xl2002 or later. In Tools|References of the VB Editor
you need to check the reference to Microsoft Scripting Runtime.
Function ArrayUniquesLtd(InputArray, _
Optional MatchCase As Boolean = True, _
Optional Base_Orient As String = "1vert", _
Optional OmitBlanks As Boolean = True)
'THIS PROCEDURE REQUIRES A PROJECT REFERENCE
'TO "MICROSCOPIC SCRIPTING RUNTIME".
'The function returns an array of unique values
'from an array or range, by default omitting
'blanks and empty strings; to include an empty
'string (or a zero for a blank), use False as
'the 4th parameter. By default the function
'returns a 1-based vertical array; for other
'results enter "0horiz", "1horiz" or "0vert" as
'the 3rd parameter. 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
'2nd parameter.
'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"
arr2 = Application.Transpose(arr2)
Case "1vert"
ReDim Preserve arr2(1 To UBound(arr2) + 1)
arr2 = Application.Transpose(arr2)
End Select
'Assure that enough cells are selected to accommodate output
If CalledDirectFromWorksheet Then
If Range(Application.Caller.Address).Count < x.Count Then
ArrayUniquesLtd = "Select a range of at least " & x.Count & " cells"
Exit Function
End If
End If
ArrayUniquesLtd = arr2
End Function
Alan Beban
