Duplicates or Unique Values
Last week I posted about a user-defined function to get the unique values in a range. I’ve now extended this function to return unique or duplicate values based on a parameter passed through the function call. so the function definition now changes from :
to
If you want the function to return Unique values only, then set GetUnique to 1 in your function call. Setting GetUnique to 0 will return Duplicate values.
The function basically imports all the values in the range to the array Entries with a corresponding array EntCount that counts the number of occurrences of every value. The rest is easy to figure out.
Obviously, it would be a good idea to create your own add-in where you can have such functions at close range for your every-day use.
Here’s the code (remember to correct the comments).
Dim Entries() As String, EntCount() As Integer
Dim GetUniques() As Variant
Dim EntryCount, i As Integer
Dim Cell As Range
Dim Found As Boolean
EntryCount = 0
For Each Cell In AllCells
Found = False
If EntryCount = 0 Then
EntryCount = EntryCount + 1
Found = True
ReDim Preserve Entries(EntryCount)
ReDim Preserve EntCount(EntryCount)
Entries(1) = Cell.Value
EntCount(1) = 1
End If
i = 1
While i <=”" entrycount and Not Found
If Entries(i) = Cell.Value Then
Found = True
EntCount(i) = EntCount(i) + 1
End If
i = i + 1
Wend
If Not Found Then
EntryCount = EntryCount + 1
Found = True
ReDim Preserve Entries(EntryCount)
ReDim Preserve EntCount(EntryCount)
Entries(i) = Cell.Value
EntCount(i) = 1
End If
Next Cell
Dim j, SwapInt As Integer
Dim SwapStr As String
For i = 1 To EntryCount - 1
For j = i + 1 To EntryCount
If Entries(i) > Entries(j) Then
SwapStr = Entries(j)
Entries(j) = Entries(i)
Entries(i) = SwapStr
SwapInt = EntCount(j)
EntCount(j) = EntCount(i)
EntCount(i) = SwapInt
End If
Next j
Next i
Dim OutCount As Integer
OutCount = 0
If GetUnique = 1 Then
For i = 1 To EntryCount
If EntCount(i) = 1 Then
GetUniques(OutCount) = Entries(i)
OutCount = OutCount + 1
End If
Next i
ElseIf GetUnique = 0 Then
For i = 1 To EntryCount
If EntCount(i) > 1 Then
ReDim Preserve GetUniques(OutCount)
GetUniques(OutCount) = Entries(i)
OutCount = OutCount + 1
End If
Next i
End If
FilterUniques = GetUniques
If AllCells.Rows.Count >= AllCells.Columns.Count Then
FilterUniques = WorksheetFunction.Transpose(FilterUniques)
End If
End Function
screen-shot :
This bit code looks ideal for what I am looking to do. However I am having some trouble getting it work correctly.
When the code is pasted the debugger picks up this line:
While i
Comment by yeti — November 16, 2005 @ 3:36 pm