Zeilen vergleichen und bestimmte Spalte addieren

Sub Konsolidieren()
QTabelle = "Tabelle1"   'Quelltabelle  
QAbZeile = 1            'Überschriftenzeile in Quelltabelle  
QAbSpalte = 1           'Nummer der 1. Datenspalte in Quelltabelle  
QDatumSpalte = "E"      'Spalte für Eintragsdatum in Quelldatei  
QBSpalte = "F"          'Spalte für Betrag in Quelltabelle  
Spalten = 4             'Spaltenanzahl für Vergleich  
ZTabelle = "Tabelle2"   'Zieltabelle  
ZAbZeile = 1            'Überschriftenzeile in Zieltabelle  
ZAbSpalte = 1           'Nummer der 1. Datenspalte in Zieltabelle  
ZDatumSpalte = "E"      'Spalte für Eintragsdatum in Zieldatei  
ZBSpalte = "F"          'Spalte für Betag in Zieltabelle  

Delim = "§"             'Trennzeichen - darf in den Daten nicht vorkommen  

Set d = CreateObject("Scripting.Dictionary")  
QZeile = QAbZeile 'in Überschriftenzeile der Quelltabelle starten  
With Worksheets(QTabelle)
    Do Until .Cells(QZeile, QAbSpalte) = "" 'Zeilen bearbeiten, bis in erster Spalte kein Wert mehr vorhanden  
        K = "" 'Schlüssel initialisieren  
        For i = 0 To Spalten - 1 'alle Schlüsselspalten durchgehen  
            K = K & Delim & .Cells(QZeile, QAbSpalte + i) 'Schlüssel zusammensetzen  
        Next
        K = Mid(K, 2) 'erstes Zeichen ist ein Trennzeichen - weglassen  
        EinDat = .Cells(QZeile, QDatumSpalte) 'Eintragsdatum auslesen  
        Betrag = .Cells(QZeile, QBSpalte) 'Betrag auslesen  
        If d.Exists(K) Then 'Wenn schon ein Eintrag für diesen Schlüssel vorhanden, ...  
            V = Split(d.Item(K), Delim) '... gespeicherte Wertekombination "Datum§Betrag" zerlegen, ...  
            V(1) = V(1) + Betrag '... Betrag addieren und ...  
            d.Item(K) = Join(V, Delim) '... wieder zusammensetzen und eintragen; ...  
        Else
            d.Add K, EinDat & Delim & Betrag '... ansonsten Eintrag als Kombination "Datum§Betrag" erstellen  
        End If
        QZeile = QZeile + 1 'nächste Zeile der Quelltabelle  
    Loop
End With

T = d.Keys 'Schlüssel-Texte in Array übernehmen  
B = d.Items 'Datumswerte und Beträge detto  
With Worksheets(ZTabelle)
    .Cells.ClearContents 'Zieltabelle löschen  
    ZZeile = ZAbZeile 'in Überschriftenzeile der Zieltabelle beginnen  
    For i = 0 To UBound(T) 'alle konsolidierten Einträge durchgehen  
        'Schlüssel-Text wieder in Spalten zerlegen und eintragen  
        .Cells(ZZeile, ZAbSpalte).Resize(1, Spalten) = Split(T(i), Delim)
        V = Split(B(i), Delim) 'Kombination "Datum§Betrag" zerlegen  
        .Cells(ZZeile, ZDatumSpalte) = V(0) 'Eintragsdatum eintragen  
        .Cells(ZZeile, ZBSpalte) = V(1) 'Betrag(ssumme) eintragen  
        ZZeile = ZZeile + 1 'nächste Zeile der Zieltabelle  
    Next
End With
End Sub