Option Explicit
Sub Excel_ZeilenZusammenfassenItemIDValue()
'<<<<< A N P A S S E N >>>>>>>>>>>>>>>>>>
Const cSP_ITEM = 2
Const cSP_VALUE = 3
Const cZ_ERSTEWERTEZEILE = 2
'<<<<< A N P A S S E N E N D E >>>>>>>
Dim ws As Worksheet, rs As Range, rd As Range
Dim lLetzteSP As Long, lLetzteZ As Long, lLetzteZItem As Long
Dim lSPReihenfolge As Long, lLetzteZReihenfolge As Long
Dim lanf As Long, lend As Long
Set ws = ActiveSheet
lLetzteSP = ws.UsedRange.Column + ws.UsedRange.Columns.Count - 1
lLetzteZ = ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1
lSPReihenfolge = lLetzteSP + 1
->a) in nächste frei Spalte Reihenfolgenummer eintragen,
-> um die alte Reihenfolge wieder herzustellen
ws.Cells(cZ_ERSTEWERTEZEILE, lSPReihenfolge).Value = 1
Set rs = ws.Range(ws.Cells(cZ_ERSTEWERTEZEILE, lSPReihenfolge), _
ws.Cells(cZ_ERSTEWERTEZEILE, lSPReihenfolge))
Set rd = ws.Range(ws.Cells(cZ_ERSTEWERTEZEILE, lSPReihenfolge), _
ws.Cells(lLetzteZ, lSPReihenfolge))
rs.AutoFill Destination:=rd, Type:=xlFillSeries
->b) gesamten Bereich nach ITEM sortieren
Set rs = ws.Range(ws.Cells(cZ_ERSTEWERTEZEILE, 1), _
ws.Cells(lLetzteZ, lSPReihenfolge))
rs.Sort _
Key1:=ws.Cells(cZ_ERSTEWERTEZEILE, cSP_ITEM), Order1:=xlAscending, _
Key2:=ws.Cells(cZ_ERSTEWERTEZEILE, lSPReihenfolge), Order2:=xlAscending, _
Header:=xlNo
->### Korrektur: Reihenfolge zur Sicherheit mit aufgenommen
->c) letzte Zeile für Item bestimmen
lLetzteZItem = ws.Cells(ws.Rows.Count, cSP_ITEM).End(xlUp).Row
->d) gleiche Zeilen zusammenfassen (VALUE addieren)
->ENDE ITEM setzen
lend = lLetzteZItem
Do While lend >= cZ_ERSTEWERTEZEILE
lanf = lend
Do While (lanf > cZ_ERSTEWERTEZEILE) And _
(ws.Cells(lanf - 1, cSP_ITEM).Value = ws.Cells(lend, cSP_ITEM).Value)
->VALUE aufaddieren
lanf = lanf - 1
ws.Cells(lanf, cSP_VALUE).Value = _
ws.Cells(lanf, cSP_VALUE).Value + ws.Cells(lanf + 1, cSP_VALUE).Value
Loop
->ggf. Zeilen löschen
If lanf <> lend Then ws.Rows((lanf + 1) & : & lend).Delete
->ENDE ITEM setzen
lend = lanf - 1
Loop
->e) letzte Zeile für Reihenfolgespalte bestimmen
lLetzteZReihenfolge = ws.Cells(ws.Rows.Count, lSPReihenfolge).End(xlUp).Row
->f) Zeilen wieder in alte reihenfolge bringen
Set rs = ws.Range(ws.Cells(cZ_ERSTEWERTEZEILE, 1), _
ws.Cells(lLetzteZReihenfolge, lSPReihenfolge))
rs.Sort _
Key1:=ws.Cells(cZ_ERSTEWERTEZEILE, lSPReihenfolge), Order1:=xlAscending, _
Header:=xlNo
->g) zusätzlich Reihenfolge-Spalte löschen
Set rd = ws.Range(ws.Cells(cZ_ERSTEWERTEZEILE, lSPReihenfolge), _
ws.Cells(lLetzteZ, lSPReihenfolge))
rd.Clear
AUFRAEUMEN:
Set ws = Nothing: Set rs = Nothing: Set rd = Nothing
End Sub
