Solved: Duplicates... How to Count and Add Them.

[ihightower]

Say, my program is writing something like this into several cells (range a1:z100 for example).. with vbCrLf

Fruit and Amount

Apple, 500
Apple, 200
Orange, 100
Pear, 100
Apple, 30
Orange, 30

I want to eliminate the duplicates.. and only show the following in that cell.
..Fruit Name -Sum of All the Amount (Count of the Fruit)

Apple-730(3)
Orange-130(2)
Pear-100(1)


Then do the same for all the cells.

I tried to use array, dictionary.. etc. but couldn't find a proper solution.

Please help.

[Bob Phillips]

Try a formula

=SUMIF(A:A,A1,B:B)&"("&COUNTIF(A:A,A1)&")"

[Kenneth Hobs]

You can change the vblf to vbcrlf if needed. If I understand correctly:
[VBA]Sub SumFruitCells()
Dim s() As String, r As Range, cell As Range
Set r = Range("A1:Z100")
For Each cell In r
s() = SumFruits(cell.Value)
cell.Value = Join(s(), vbCrLf)
Next cell
End Sub

Function SumFruits(fruitString As String)
Dim a() As String, b() As String, c() As String
Dim u() As String, aFruit() As String, aCount() As String, aFruitCount() As String
Dim i As Integer, j As Integer, coll As New Collection
Dim sCount As Double, iCount As Integer

'Split and make arrays with fruit names and quantities.
a() = Split(Replace(fruitString, ",", ""), vbLf)
b() = a()
c() = a()

'Remove duplicate fruit names and put in collection.
On Error Resume Next
For i = 0 To UBound(a)
b(i) = Split(a(i))(0)
c(i) = Split(a(i))(1)
coll.Add b(i), b(i)
Next i
On Error GoTo 0
ReDim u(0 To coll.Count)

'Build the union array of "Fruit Names-Sum(Count)".
For j = 1 To coll.Count
sCount = 0
iCount = 0
For i = 0 To UBound(b)
If coll(j) = b(i) Then
sCount = sCount + c(i)
iCount = iCount + 1
End If
Next i
u(j) = coll(j) & "-" & sCount & "(" & iCount & ")"
Next j
SumFruits = u()
End Function


[/VBA]

[someboddy]

That's what pivots are for

[ihightower]

Thank you so much Kenneth Hobs... Your code is great... but it didn't work the first time round... I had to do some minor modifications.. and it now works perfectly... The modifications and the final code is given below.

the modifications are mainly due to:

sCount = sCount + Val(c(i))... in this line.. I had to add Val because without it.. type mismatch error

in the below two lines.. i had to add the "-".. to split it correctly between Fruit and the Amount.

b(i) = Split(a(i), "-")(0)
c(i) = Split(a(i), "-")(1)


- coll starts from index:1 and so there was an extra space on top line.. used tmpj to fix this.

- and added some checks to make sure i don't process an empty cell to avoid errors.


someboddy: thank you for your comments.. I couldn't use pivot.. because the parsing is to be done within a cell (of multiple lines vbcrlf).. and I don't know how i could use pivot with in the code to parse all the vbcrl and do splits.



[vba]
Sub SumFruitCells()

Dim s() As String, r As Range, cell As Range

Set r = Sheet13.Range("b2:y34")

For Each cell In r

If Len(cell.Value) < 3 Then GoTo Nextcell:

s() = SumFruits(cell.Value)
cell.Value = Join(s(), vbCrLf)

Nextcell:

Next cell

End Sub

Function SumFruits(fruitString As String)

Dim a() As String, b() As String, c() As String
Dim u() As String, aFruit() As String, aCount() As String, aFruitCount() As String
Dim i As Integer, j As Integer, coll As New Collection
Dim sCount As Double, iCount As Integer

'Split and make arrays with fruit names and quantities.
a() = Split(Replace(fruitString, ",", ""), vbCrLf)
b() = a()
c() = a()

'Remove duplicate fruit names and put in collection.
On Error Resume Next
For i = 0 To UBound(a)

b(i) = Split(a(i), "-")(0)
c(i) = Split(a(i), "-")(1)

If (Len(b(i)) > 3) Then

coll.Add b(i), b(i)

End If

Next i

On Error GoTo 0

ReDim u(0 To coll.Count - 1)

'Build the union array of "Fruit Names-Sum(Count)".
For j = 0 To coll.Count - 1

tmpj = j + 1

sCount = 0
iCount = 0

For i = 0 To UBound(b)

If coll(tmpj) = b(i) Then

sCount = sCount + Val(c(i))
iCount = iCount + 1

End If

Next i

u(j) = coll(tmpj) & "-" & sCount & "(" & iCount & ")"

Next j

SumFruits = u()

End Function


[/vba]