Hi,

alternativ mit Hilfstabelle(n)

Option Explicit
Sub TotalMe()
Rem wie beschrieben
Rem A             B       (A=1, B=2)
Rem Artikel -Nr.  Anzahl
'
Rem mit Hilfstabellen
Rem Kopieren
Rem Sortieren
Rem Teilergebnis
Rem  Duplikate u.a. entfernen
'
Dim Warnung As Boolean
Dim Ergebnisse As Range
Dim x As Long
Dim DatenTab As Worksheet
Dim TeilErgb As Worksheet
'
Application.ScreenUpdating = False
'
  Set DatenTab = ActiveSheet
'
  DatenTab.Copy After:=Sheets(Worksheets.Count)
  Set TeilErgb = Sheets(Worksheets.Count)
  With TeilErgb.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A:A")
    .SetRange Range("A:B")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
  End With
'
  With TeilErgb.Range("A:B")
    .Subtotal _
      GroupBy:=1, _
      Function:=xlSum, _
      TotalList:=Array(2)
    .Copy
  End With
'
  Sheets.Add After:=Sheets(Worksheets.Count)
  Range("A1").PasteSpecial _
    Paste:=xlPasteValues
    Application.CutCopyMode = False
    ActiveSheet.Range("A:B").RemoveDuplicates _
    Columns:=1, Header:=xlYes
'
  For x = Range("A2").End(xlDown).Row To 2 Step -1
    If InStr(Cells(x, 1).Formula, "Ergebnis") = 0 Then _
      Rows(x).Delete
  Next x
  For x = Range("A2").End(xlDown).Row To 2 Step -1
    Cells(x, 1).Formula = Replace(Cells(x, 1).Formula, "Ergebnis", "")
  Next x
'
  Range("A1").Select
  Warnung = Application.DisplayAlerts
  Application.DisplayAlerts = False
  TeilErgb.Delete
  Application.DisplayAlerts = Warnung
'
Set DatenTab = Nothing
Set TeilErgb = Nothing
'
Application.ScreenUpdating = True
End Sub