Sub СуммОдинаков()
      ' просуммировать дублирующий материал и удалить отработанное
                Dim x, y(), m&, J&, k&, N&, s$
                x = Range("B1:D" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Value
                ReDim y(1 To UBound(x), 1 To UBound(x, 2))
                On Error Resume Next
                With New Collection
                    For m = 1 To UBound(x)
                        s = x(m, 1) & "~" & x(m, 2)
                        If IsEmpty(.Item(s)) Then
                            k = k + 1
                            For J = 1 To UBound(x, 1)
                    y(k, J) = x(m, J)
                            Next J
                            .Add Item:=k, Key:=s
                        Else
                            N = .Item(s)
                            y(N, 3) = y(N, 3) + x(m, 3)
                        End If
                    Next m
                End With
                With Range("B1:D" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
                 .ClearContents: .Resize(k).Value = y()
                End With
    ' закрыть Макрос
Workbooks("макрос.xlsm").Close SaveChanges:=False
End Sub