Here's a different approach using Autofilter and the Subtotal function:
Sub SubTotalUniques()
Dim Uniques As Collection
Dim r As Range
Dim r2 As Range
Dim c As Range
Dim cnt As Long
Const ic As Long = 1 'Invoice Column change to suit
Const sc As Long = 2 'Sum Column change to suit
Const afr As String = "A1" 'Autofilter start Range change to suit
If Not ActiveSheet.FilterMode Then ActiveSheet.Range(afr).AutoFilter
Set r = ActiveSheet.AutoFilter.Range
Set Uniques = New Collection
On Error Resume Next ' ignore any errors
For Each c In r.Columns(1).Resize(r.Rows.Count - 1).Offset(1).Cells
Uniques.Add c.Value, CStr(c.Value) ' add the unique item
Next
On Error GoTo 0
Set r2 = r.Cells(r.Rows.Count, 1).Offset(2)
r2 = "=SUBTOTAL(109," & r.Columns(2).Resize _
(r.Rows.Count - 1).Offset(1).Address & ")"
For cnt = 1 To Uniques.Count
r.AutoFilter Field:=r.Columns(1).Column, Criteria1:=Uniques(cnt)
Worksheets("Sheet2").Range("A" & cnt) = Uniques(cnt)
Worksheets("Sheet2").Range("B" & cnt) = r2.Value
Next
ActiveSheet.AutoFilterMode = False
r2.Delete Shift:=xlUp
End Sub
Let me know if you have problems.
--
Charles Chickering
"A good example is twice the value of good advice."
"allie357" wrote:
> I have a spreadsheet will a large amount of invoice numbers, some of
> which are multiple occurrences of the same number. I need to count the
> duplicates as one unique record and sum but I need to sum the total $
> amount of each amount attached to each occurrence. For Example, say
> Invoice Number W234678 has 10 occurrences and corresponding amounts. I
> need the amounts to be added to give a total amount for that number
> and then have Invoice Number W234678 added to the count as one
> record.
> I had this code kindly borrowed from this board which helped me find
> the duplicates but it is not meeting my needs.
>
> Thanks in advance for any help!
>
>
Code:
> Dim rCell As Range, rRng As Range, vKey, lrow As Long
>
>
>
> Set rRng = Range("F2:F199")
>
>
>
> With CreateObject("Scripting.dictionary")
>
> .comparemode = vbTextCompare
>
>
>
> ' load the info
>
> For Each rCell In rRng
>
> If Not .exists(rCell.Value) Then _
>
> .Add rCell.Value,
> Application.WorksheetFunction.CountIf(rRng, rCell.Value)
>
> Next rCell
>
>
>
> ' Write the result in columns J:K
>
> lrow = 2
>
> For Each vKey In .keys
>
> If .Item(vKey) > 1 Then
>
> Cells(lrow, "J") = vKey
>
> Cells(lrow, "K") = .Item(vKey) - 1
>
> lrow = lrow + 1
>
> End If
>
> Next vKey
>
> End With
>
> End Sub
>
>
>