■

http://q.hatena.ne.jp/1301453031

既に解決しているようなので作らないかなと思っていましたが、
なんか無理とか言ってる人がいたのでさくさくっと作っておきます。
A列が同じ数で並んでいるとは限らないのでそれにも対応しておきました。
数万行とかなら数式はナンセンスなんで、VBAの価値もあるか。

Sub Macro()
    Application.ScreenUpdating = False
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim f As Boolean
    Dim h() As String
    Dim lastRow As Long
    Dim r As Range
    
    lastRow = Cells(Rows.count, "A").End(xlUp).Row
    
    For i = 1 To lastRow
        For j = lastRow To i Step -1
            If Cells(i, "A").Value = Cells(j, "A").Value Then
                Cells(j, "F").Value = Cells(j, "F").Value + Cells(i, "G").Value
                Exit For
            End If
        Next j
    Next i
    
    For i = 1 To lastRow
        If Cells(i, "F").Value <> "" Then
            ReDim h(0)
            For j = 1 To i
                If Cells(i, "A").Value = Cells(j, "A").Value Then
                    f = False
                    For k = 0 To UBound(h)
                        If h(k) = Cells(j, "C").Value Then
                            f = True
                            Exit For
                        End If
                    Next k
                    If Not f Then
                        ReDim Preserve h(UBound(h) + 1)
                        h(UBound(h)) = Cells(j, "C").Value
                    End If
                End If
            Next j
            Cells(i, "D").Value = UBound(h)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

削除して小計行だけを残すマクロです。

Sub Macro2()
    Application.ScreenUpdating = False
    Dim i As Long
    Dim j As Long
    Dim lastRow As Long
    
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    Range("G:G").Copy Range("F:F")
    For i = 1 To lastRow
        For j = i + 1 To lastRow
            If Cells(i, "A").Value = Cells(j, "A").Value And _
                Cells(i, "C").Value = Cells(j, "C").Value Then
                Cells(j, "F").Value = Cells(j, "F").Value + Cells(i, "F").Value
                Rows(i).Delete
                i = i - 1
                lastRow = lastRow - 1
                Exit For
            End If
        Next j
    Next i
    
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Range(Cells(1, "D"), Cells(lastRow, "D")).Value = 1
    For i = 1 To lastRow
        For j = i + 1 To lastRow
            If Cells(i, "A").Value = Cells(j, "A").Value Then
                Cells(j, "F").Value = Cells(j, "F").Value + Cells(i, "F").Value
                Cells(j, "D").Value = Cells(j, "D").Value + Cells(i, "D").Value
                Rows(i).Delete
                i = i - 1
                lastRow = lastRow - 1
                Exit For
            End If
        Next j
    Next i
    
    Application.ScreenUpdating = True
End Sub