UDF to Count, but delete duplicate entries in a range using Excel2003

[adam_kroger]

--Given--
_________________________
A B C D
1 Fred Fred
2 apple red
3 red blue
4 now
_________________________

I am using a UDF to return the value:
"Fred Fred apple red red blue now"
I would like to have:
"Fred(2) apple red(2) blue now" <--- duplicate entries counted
but removed
Or even better:
"apple, blue, Fred(2), now, red(2)" <---Alphabatized with commas
between the entries

Ideally it would even ignore variations in capitalization (FrEd = fred
= Fred) and report everything in ALL CAPS.

This is the VBA as it is now:
------------------------------------------------------------------
Function join_function(MyRng As Range)
Dim MyCell As Range
Dim output As String
For Each MyCell In MyRng
Found = False
If Application.WorksheetFunction.IsText(MyCell) = True Then
output = output & MyCell.Value & " "
End If
Next
join_function = output

End Function
------------------------------------------------------------------
and I am calling it from inside a cell like this:
=join_function(A14) or =join_function(NamedRange)
***
The function is used in an activity tracking WorkBook that has 4
cells labeled "OTHER" for each day. It is used to produces Weekly,
Quarterly, Semi-Annual, and Annual totals for 12 employees (each
employee has a seperate sheet). These summaries are retreived via an
INDEX(MATCH()) on another worksheet and reported by a MsgBox from a
command button.

I can live with it the way it is now, but... well... we all always
want more

 

[Dave Peterson]

Maybe something like:

Option Explicit
Function myJoin(rng As Range) As String

'unique list and sorting taken from:
'http://j-walk.com/ss/excel/tips/tip47.htm

Dim NoDupes As Collection
Dim myCell As Range
Dim i As Long
Dim j As Long
Dim Swap1 As Variant
Dim Swap2 As Variant
Dim myStr As String
Dim HowMany As Long
Dim ThisElement As String

Set NoDupes = New Collection


For Each myCell In rng.Cells
If myCell.Value = "" Then
'skip it
Else
On Error Resume Next
NoDupes.Add Item:=myCell.Value, key:=CStr(myCell.Value)
On Error GoTo 0
End If
Next myCell

myStr = ""
If NoDupes.Count > 0 Then
'Sort the collection
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If lCase(NoDupes(i)) > lCase(NoDupes(j)) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i

For i = 1 To NoDupes.Count
HowMany = Application.CountIf(rng, NoDupes(i))
If HowMany > 1 Then
ThisElement = NoDupes(i) & " (" & HowMany & ")"
Else
ThisElement = NoDupes(i)
End If
myStr = myStr & ", " & ThisElement
Next i

If myStr <> "" Then
myStr = Mid(myStr, 3)
End If

End If

myJoin = myStr

End Function

 

[adam_kroger]

Thank You, it works great

Maybe something like:

Option Explicit
Function myJoin(rng As Range) As String

'unique list and sorting taken from:
'http://j-walk.com/ss/excel/tips/tip47.htm

Dim NoDupes As Collection
Dim myCell As Range
Dim i As Long
Dim j As Long
Dim Swap1 As Variant
Dim Swap2 As Variant
Dim myStr As String
Dim HowMany As Long
Dim ThisElement As String

Set NoDupes = New Collection

For Each myCell In rng.Cells
If myCell.Value = "" Then
'skip it
Else
On Error Resume Next
NoDupes.Add Item:=myCell.Value, key:=CStr(myCell.Value)
On Error GoTo 0
End If
Next myCell

myStr = ""
If NoDupes.Count > 0 Then
'Sort the collection
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If lCase(NoDupes(i)) > lCase(NoDupes(j)) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i

For i = 1 To NoDupes.Count
HowMany = Application.CountIf(rng, NoDupes(i))
If HowMany > 1 Then
ThisElement = NoDupes(i) & " (" & HowMany & ")"
Else
ThisElement = NoDupes(i)
End If
myStr = myStr & ", " & ThisElement
Next i

If myStr <> "" Then
myStr = Mid(myStr, 3)
End If

End If

myJoin = myStr

End Function












--

Dave Peterson- Hide quoted text -

- Show quoted text -

 

[Harlan Grove]

Maybe something like:

Option Explicit
Function myJoin(rng As Range) As String ....
For Each myCell In rng.Cells

....

Load NoDupes collection

myStr = ""
If NoDupes.Count > 0 Then
'Sort the collection
For i = 1 To NoDupes.Count - 1

....

Bubble sort it.

For i = 1 To NoDupes.Count
HowMany = Application.CountIf(rng, NoDupes(i))

....

Use COUNTIF to count multiple instances.

This iterates through the range more than is necessary. Collection objects
can be used to greater effect.


Option Explicit
Option Compare Text
Function foo(r As Range) As String
Dim s As String, u As String, k As Long, x As Variant
Dim c As New Collection, d As New Collection

On Error Resume Next

'load collection c containing 1st instance of each key and its count
For Each x In r
s = x.Value
u = UCase(s)

If u <> "" Then
Call c.Item(u) 'will throw an error if u not yet in c

If Err.Number <> 0 Then '1st instance
c.Add Item:=Array(s, 1), Key:=u
Err.Clear

Else 'duplicate instance - note: use letter case of 1st instance
s = c.Item(u)(0)
k = c.Item(u)(1) + 1
c.Remove Index:=u
c.Add Item:=Array(s, k), Key:=u

End If

End If

Next x

'put c's sorted keys into collection d - still bubble sort
For Each x In c
For k = 1 To d.Count
If x(0) < d.Item(k) Then
d.Add Item:=x(0), before:=k
Exit For 'ensures 1 <= k <= d.count
End If
Next k

If d.Count = 0 Then '1st item
d.Add Item:=x(0)
ElseIf k > d.Count Then 'new last item
d.Add Item:=x(0), after:=d.Count
End If

Next x


'generate result
For Each x In d
foo = foo & ", " & c.Item(x)(0)
k = c.Item(x)(1)
If k > 1 Then foo = foo & Format(k, "\(0\)")
Next x

foo = Mid(foo, 3)
End Function

 

[Dave Peterson]

That's a pretty nice use of the Call statement. I've never seen anything like
that.