Option Explicit

Public Sub Demo()
  
  Dim at(), am()
  Dim n As Long
  
  'Auswertung:
  n = MyEvaluation(Tabelle1, at, am)
  
  If n > 0 Then
    
    Tabelle2.Columns("A").Resize(n).Value = at
    Tabelle2.Columns("B").Resize(n).Value = am
    
    Erase at, am 'Aufräumen
    
    Call MsgBox(n & " Artikel wurde(n) verarbeitet.", _
          vbInformation, _
          "Vorgang abgeschlossen")
    
  ElseIf n = 0 Then
    
    Call MsgBox("Keine Artikel zum verarbeiten gefunden.", _
          vbInformation, _
          "Vorgang abgeschlossen")
    
  Else
    Call MsgBox("Es ist ein unerwarteter Fehler aufgetreten." & vbNewLine & _
                "(siehe VBA-Direktbereich für mehr Details)", _
            vbCritical, _
            "Vorgang unterbrochen")
  End If
  
End Sub

Private Function MyEvaluation(Worksheet As Excel.Worksheet, Article(), Amount()) As Long
  
  On Error GoTo ErrHandler
  
  Dim rngData As Excel.Range
  Dim rngRS   As Excel.Range
  Dim dicT    As Object
  Dim t       As String
  
  With Worksheet.UsedRange
    Set rngData = .Resize(.Rows.Count - 1).Offset(1) 'Kopfzeile rausnehmen
  End With
  
  Set dicT = CreateObject("Scripting.Dictionary")
  
  For Each rngRS In rngData.Rows
    
    t = rngRS.Cells(1).Text
    
    If dicT.Exists(t) Then
      dicT.Item(t) = dicT.Item(t) + rngRS.Cells(2).Value
    Else
      dicT.Add t, rngRS.Cells(2).Value
    End If
    
  Next
  
  Article() = WorksheetFunction.Transpose(dicT.Keys)
  Amount() = WorksheetFunction.Transpose(dicT.Items)
  
  MyEvaluation = dicT.Count
  
  GoTo SafeExit
  
ErrHandler:
  
  Debug.Print ">> Error " & Err.Number & ": " & Err.Description & " <<"
  
  MyEvaluation = -1
  
SafeExit:
  Set rngRS = Nothing
  Set rngData = Nothing
  Set dicT = Nothing

End Function