AW: Beträge v Duplikaten summieren
26.01.2017 17:59:06
Peter
Hallo Anton,
die Array-Zeile muss natürlich so, wie in diesem Beispiel ausgegeben werden
Option Explicit
' Ich habe in Spalte D mehrere gleiche Rechnungsnummern.
' Dies kommt daher, dass in Spalte N die einzelnen Beträge der Positionen einer Rechnung _
dargestellt sind.
' Die Rechnungsnummern können natürlich unterschiedlich oft vorkommen, je nach _
Rechnungspositionen.
' Nun würde ich gerne die Zeile der Unikaten Rechnungsnummern mit summiertem Betrag ausgeben. _
Public Sub Zusammenfassen()
Dim WkSh_Q As Worksheet ' das Quell-Tabellenblatt - die Datenherkunft
Dim WkSh_Z As Worksheet ' das Ziel-Tabellenblatt - die Ausgabe
Dim objDic As Object ' das Data-Dictionary Object
Dim varArr As Variant ' ein Array der Daten
Dim lZeile As Long ' die Zeile des Arrays
Dim lZeile_Z As Long ' die Ausgabe-Zeile
Dim iSpalte As Integer ' die auszugebenden Spalten
Set WkSh_Q = ThisWorkbook.Worksheets("Tabelle1")
Set WkSh_Z = ThisWorkbook.Worksheets("Tabelle2")
Set objDic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False ' das Bildschirem-Update unterdrücken
On Error GoTo Fehler_Ausgang
' den Ausgabe-Bereich leeren/löschen
WkSh_Z.Cells.Range("A1:V" & WkSh_Z.Cells(WkSh_Z.Rows.Count, 1).End(xlUp).Row).ClearContents
' die Überschrift kopieren
WkSh_Q.Range("A3:V3").Copy Destination:=WkSh_Z.Range("A3")
lZeile_Z = 4
With WkSh_Q
' zur besseren Performance die Daten in ein Array speichern
varArr = .Range("A4:V" & .Cells(.Rows.Count, 4).End(xlUp).Row)
For lZeile = LBound(varArr) To UBound(varArr)
If IsNumeric(varArr(lZeile, 14)) Then ' ist Spalte N numerisch?
If Not objDic.Exists(varArr(lZeile, 4)) Then ' gibt es Spalte 4 - die _
Rechnungsnummer bereits?
objDic(varArr(lZeile, 4)) = objDic(varArr(lZeile, 4)) + varArr(lZeile, 14)
For iSpalte = 1 To 22
WkSh_Z.Cells(lZeile_Z, iSpalte).Value = varArr(lZeile, iSpalte)
Next iSpalte
lZeile_Z = lZeile_Z + 1
Else ' nur noch die gesplitteten Rechnungs-Werte addieren
objDic(varArr(lZeile, 4)) = objDic(varArr(lZeile, 4)) + varArr(lZeile, 14)
End If
End If
Next lZeile
End With
' das Ergebnis der Additionen (Zusammenfassungen) in Spalte N = 14 übertragen
WkSh_Z.Range("N4").Resize(objDic.Count) = Application.Transpose(objDic.items)
Fehler_Ausgang:
Set objDic = Nothing ' die Ressourcen löschen/freigeben
Set WkSh_Q = Nothing
Set WkSh_Z = Nothing
Application.ScreenUpdating = True ' das Bildschirm-Update wieder zulassen
' gibt bzw. gab es Fehler?
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Gruß Peter