unique and no blanks in one formula

[nelsok]

is there a way to get the unique entries from a list with out blanks using only one formula?

currently i use

=if(countif(a$1:a1,a1)=1,a1,"")

to get unique entries

and

Function NoBlanks(DataRange As Range) As Variant()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' NoBlanks
' This function returns an array that consists of the non-blank values
' in DataRange. The function must be array-entered into the complete range
' of worksheet cells that are to receive the result. For example, if
' you want the results in B1:B10, select that range, type
'       =NOBLANKS(A1:A10)
' in B1 and press CTRL+SHIFT+ENTER rather than just enter.
' This will cause the function to fill B1:B10 with the N non-blank
' entries in A1:A10, and place vbNullStrings in N+1 to 10.
' The input DataRange must have exactly 1 row or 1 column. You
' can't enter a two-dimensional array. The formula must be
' entered into a single column or singe row. You cannot
' enter the formula in a two dimensional array. If the formula
' is entered into a two-dimensional range, or if DataRange is a
' two dimensional range, the function will return #REF errors.
' The size of the array is the greater of the number of cells
' into which it was entered and the number of cells in the input
' DataRange.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim N As Long
Dim N2 As Long
Dim Rng As Range
Dim MaxCells As Long
Dim Result() As Variant
Dim R As Long
Dim C As Long

If (DataRange.Rows.Count > 1) And _
    (DataRange.Columns.Count > 1) Then
    '''''''''''''''''''''''''''''''''''''''''''''''''
    ' If DataRange is a two-dimensional array, fill
    ' it with #REF errors. We work with only
    ' single dimensional ranges.
    '''''''''''''''''''''''''''''''''''''''''''''''''
    ReDim Result(1 To DataRange.Rows.Count, 1 To DataRange.Columns.Count)
    For R = 1 To UBound(Result, 1)
        For C = 1 To UBound(Result, 2)
            Result(R, C) = CVErr(xlErrRef)
        Next C
    Next R
    NoBlanks = Result
    Exit Function
End If

If (Application.Caller.Rows.Count > 1) And _
    (Application.Caller.Columns.Count > 1) Then
    '''''''''''''''''''''''''''''''''''''''''''''''''
    ' If Application.Caller is a two-dimensional array, fill
    ' it with #REF errors. We work with only
    ' single dimensional ranges.
    '''''''''''''''''''''''''''''''''''''''''''''''''
    ReDim Result(1 To Application.Caller.Rows.Count, 1 To Application.Caller.Columns.Count)
    For R = 1 To UBound(Result, 1)
        For C = 1 To UBound(Result, 2)
            Result(R, C) = CVErr(xlErrRef)
        Next C
    Next R
    NoBlanks = Result
    Exit Function
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' Get the greater of Application.Caller.Cells.Count
' and DataRange.Cells.Count. This is the size
' of the array we'll return. Sizing it to the
' maximum value prevents #N/A error from appearing
' in cells past the end of the array, because
' the array will always fill out the cells
' into which it was entered.
'''''''''''''''''''''''''''''''''''''''''''''''''''''
MaxCells = Application.WorksheetFunction.Max( _
    Application.Caller.Cells.Count, DataRange.Cells.Count)

''''''''''''''''''''''''''''''''''''''''''''
' Resize the array to the proper size.
''''''''''''''''''''''''''''''''''''''''''''
ReDim Result(1 To MaxCells, 1 To 1)
''''''''''''''''''''''''''''''''''''''''''''
' Loop through DataRange and place non-blank
' cells at the front of the array.
''''''''''''''''''''''''''''''''''''''''''''
For Each Rng In DataRange.Cells
    If Rng.Value <> vbNullString Then
        N = N + 1
        Result(N, 1) = Rng.Value
    End If
Next Rng
''''''''''''''''''''''''''''''''''''''''''''
' Fill the remaining array elements with
' vbNullStrings so they don't appear
' as 0 on the worksheet.
''''''''''''''''''''''''''''''''''''''''''''
For N2 = N + 1 To MaxCells
    Result(N2, 1) = vbNullString
Next N2

'''''''''''''''''''''''''''''''''''''''''''
' If the formula was entered into a single
' row across several columns, Transpose the
' result array.
'''''''''''''''''''''''''''''''''''''''''''
If Application.Caller.Rows.Count = 1 Then
    NoBlanks = Application.Transpose(Result)
Else
    NoBlanks = Result
End If

End Function

to get the list without blanks.


thanks.

 

[ravishankar]

Hi
try the following macro. Keep C1 free.

Sub List_Unique()
d = 1
x = Cells(Rows.Count, 1).End(xlUp).Row
For a = 1 To x
c = "A1:A" & x
Cells(1, 3) = "=countif(" & c & ", A" & a & ")"
If Cells(1, 3) = 1 Then
Cells(d, 2) = Cells(a, 1)
d = d + 1
Else
End If
Next a
End Sub

If col A has the list, it will find unique values and lists them in col B.
Ravi

 

[nelsok]

im confused about how to use the code you have shown.

Why must c1 remain free if column a and b are being used.


Does this macro leave blank spaces where a duplicate value was removed?

 

[ravishankar]

Hi
press Alt F11, Insert module and paste the above code and run the macro.
I have used C1 to calculate countif function. So it should be free. It does not remove duplicate values. It only lists items that are not duplicate.
Ravi

 

[nelsok]

so if i am understanding correctly:

1
1
2
3
3
4
5


would result in
2
4
5


is this correct?

if so I was trying to accomplish this:
1
2
3
4
5
where all unique values are show, duplicate entries removed but still accounted for.


Do you have a method for doing this?

 

[ravishankar]

Hi
select the column, goto DATA menu, > Filter > Advanced filter > Click copy to another location > select the location (say C1) into "copy to" > click unique records only > click OK
Ravi

 

[Yogi Anand]

Hi neslok:

Following is a formula based approach using UNIQUEVALUES function from MoreFunc Add-in ...

Book2
	A	B	C	D	E
1				UniqueValues
2		1		1
3		1		2
4		2		3
5		3		4
6		3		5
7		4
8		5
9
Sheet10

array formula in cell D2:D8 is ... =UNIQUEVALUES(B2:B8,1)

 

[jindon]

1) select vertical multiple cells
2) =Unique(A1:A10,1) 1 for non case sensitive, else case sensitive
3) confirm with Ctrl + Shift + Enter (Array formula)

Function UniqueOnly(rng As Range, CompareMode As Byte) As Variant
Dim r As Range
With CreateObject("Scripting.Dictionary")
     .CompareMode = IIf(CompareMode = 1, vbTextCompare, vbBinaryCompare)
     For Each r In rng
          If (r.Value <> "") * (Not .exists(r.Value) Then .add, Nothing
     Next
     UniqueOnly = WorksheetFunction.Transpose(.keys)
End With
End Function

 

[nelsok]

1) select vertical multiple cells
2) =Unique(A1:A10,1) 1 for non case sensitive, else case sensitive
3) confirm with Ctrl + Shift + Enter (Array formula)

Function UniqueOnly(rng As Range, CompareMode As Byte) As Variant
Dim r As Range
With CreateObject("Scripting.Dictionary")
     .CompareMode = IIf(CompareMode = 1, vbTextCompare, vbBinaryCompare)
     For Each r In rng
          If (r.Value <> "") * (Not .exists(r.Value) Then .add, Nothing
     Next
     UniqueOnly = WorksheetFunction.Transpose(.keys)
End With
End Function

when i try to run this function it says that there is a compile error: syntax error

and it turns the if statment red and the first line yellow. Any idea how to fix?

 

[jindon]

Sorry, missed ")"

Function UniqueOnly(rng As Range, CompareMode As Byte) As Variant
Dim r As Range
With CreateObject("Scripting.Dictionary")
     .CompareMode = IIf(CompareMode = 1, vbTextCompare, vbBinaryCompare)
     For Each r In rng
          If (r.Value <> "") * (Not .exists(r.Value)) Then .add, Nothing
     Next
     UniqueOnly = WorksheetFunction.Transpose(.keys)
End With
End Function