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