Option Explicit
Public Sub Demo()
Dim at(), am()
Dim n As Long
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
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)
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