ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Determining and presenting unique entries? (https://www.excelbanter.com/excel-programming/318432-determining-presenting-unique-entries.html)

[email protected]
Determining and presenting unique entries?
 
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

Alan Beban[_2_]
Determining and presenting unique entries?
 
wrote:
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

gocush[_28_]
Determining and presenting unique entries?
 
Assuming you are using col A and B and assuming you have headers in A1 and B1
with data starting in A2=blank A3=Test1 A4=blank etc
and assuming that when you say that the data is "actually used" then the
data must be in a particular row and that the first cell of that row ("A??")
will not be blank,
then the following will copy whatever is found in Col A cell to Col B cells:

This will produce the image you showed in your post

Option Explicit

Private Sub FindNonBlanks()
Dim c As Range
Dim LastC As Range
Dim i As Integer
Set LastC = Range("A65354").End(xlUp)
For Each c In Range("A2", LastC)
If c < "" Then
Range("B2").Offset(i, 0) = c.Value
i = i + 1
End If
Next c
End Sub

" wrote:

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

[email protected]
Determining and presenting unique entries?
 
This works perfectly! Thanks very much.


All times are GMT +1. The time now is 12:36 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com