Hallo Martin,

genau dieses Problem hatte ich vor einigen Wochen auch noch. Habe "auf die Schnelle" folgendes Script erstellt:

Sub Consolidate()

Dim cSource
Dim cSourceChar As String
Dim cTarget As Variant
Dim cTargetChar As String
Dim cAddress As Range
Dim cRows As Integer
Dim cColumns As Integer
Dim cFirstRow As Integer
Dim cLastRow As Integer
Dim cFirstColumn As Integer
Dim cLastColumn As Integer
Dim cFirstCell As Range
Dim cRowDelete As Integer
Dim cActiveRow As Integer
Dim cSelectedRows As Integer
Dim cTemp As Integer
Dim i As Integer

Application.ScreenUpdating = False
cSource = InputBox("In welcher Spalte der Auswahl soll nach gleichen Einträgen gesucht werden?" & vbCrLf & vbCrLf & "Bitte den Buchstaben der Bezugsspalte eingeben.", "Bezugsspalte wählen")
If cSource = "" Then Exit Sub
cSourceChar = cSource
cSource = Range(cSource & ":" & cSource).Column 'Buchstabe zu Zahl
'cAddress = Selection.Cells.Address      'Adresse der gesamten Markierung (Range)
'cFirstCell = Cells(sFirstRow, sFirstColumn) 'Adresse der ersten Zelle in der Markierung (Range)
cRows = Selection.Rows.Count            'Anzahl Reihen der Auswahl (Integer)
cColumns = Selection.Columns.Count      'Anzahl Spalten der Auswahl (Integer)
cFirstRow = Selection.Cells.Row         'erste Reihe der Auswahl (Integer)
cLastRow = cFirstRow + cRows - 1        'letzte Reihe der Auswahl (Integer)
cFirstColumn = Selection.Cells.Column   'erste Spalte der Auswahl (Integer)
cLastColumn = cFirstColumn + cColumns - 1   'letzte Spalte der Auswahl (Integer)
If cSource < cFirstColumn Or cSource > cLastColumn Then
    MsgBox "Die angegebene Spalte (" & cSourceChar & ") befindet sich außerhalb der Auswahl."
    Exit Sub
End If
cTargetChar = InputBox("In welcher Spalte der Auswahl befinden sich die zu addierenden Werte?" & vbCrLf & vbCrLf & "Bitte den Buchstaben der Wertespalte eingeben." & vbCrLf & vbCrLf & "Mehrere Wertespalten mit "","" oder "","" trennen:" & vbCrLf & """a,b,c,..."" oder ""a+b+c+...""", "Wertespalte(n) wählen")
If cTargetChar = "" Then Exit Sub
cTargetChar = Replace(cTargetChar, " ", "")
cTargetChar = Replace(cTargetChar, ",", "+")
cTarget = Split(cTargetChar, "+")
For i = 0 To UBound(cTarget)
    cTarget(i) = Range(cTarget(i) & ":" & cTarget(i)).Column
    cTemp = Range(cSourceChar & ":" & cSourceChar).Column  'Komplette Schleife funktioniert NUR mit "cTemp"! Direkte Wertezuordnung (warum auch immer) nicht möglich!
    If cTarget(i) = cTemp Then
        MsgBox "Wertespalten dürfen sich nicht auf die Bezugsspalte beziehen!", vbCritical
        MsgBox cTarget(i) & " ist gleich " & cTemp
        Exit Sub
    End If
    cTemp = cFirstColumn    'Selection.Cells(1).Column
    If cTarget(i) < cTemp Then
        MsgBox "Mindestens eine der angegebenen Wertespalten befindet sich außerhalb der Auswahl."
        Exit Sub
    End If
    cTemp = cLastColumn 'Selection.Cells(Selection.Count).Column        richtig ersetzt????
    If cTarget(i) > cTemp Then
        MsgBox "Mindestens eine der angegebenen Wertespalten befindet sich außerhalb der Auswahl."
        Exit Sub
    End If
Next i
cRowDelete = MsgBox("Reihen mit doppelten Einträgen werden komplett gelöscht." & vbCrLf & vbCrLf & "Sollen alternativ nur die betroffenen Zellen gelöscht werden?", vbYesNoCancel + vbQuestion, "Doppelte Werte zusammenfassen")
If cRowDelete = vbCancel Then Exit Sub
If MsgBox("Gleiche Einträge in der Bezugsspalte (" & cSourceChar & ") werden in der" & vbCrLf & "Wertespalte (" & cTargetChar & ") zusammengefasst." & vbCrLf & vbCrLf & "Diese Aktion kann nicht rückgängig gemacht werden." & vbCrLf & "Wirklich fortfahren?", vbYesNo + vbExclamation, "Leere Reihen löschen") = vbNo Then Exit Sub
'Hilfsspalte erstellen und mit Zahlen füllen
Columns(cFirstColumn).EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
For i = 1 To cRows
    Cells(cFirstRow + i - 1, cFirstColumn).Value = i
Next i
Range(Cells(cFirstRow, cFirstColumn), Cells(cLastRow, cLastColumn + 1)).Select  '+1, da neue Spalte mit einbezogen wird
'Sortieren
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(cFirstRow, cSource + 1), Cells(cFirstRow, cSource + 1)), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
    .SetRange Range(Cells(cFirstRow, cFirstColumn), Cells(cLastRow, cLastColumn + 1))
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
'Doppelte Werte finden und zusammenfügen
Cells(cFirstRow, cSource + 1).Select
cCount = 0
cActiveRow = cFirstRow
cSelectedRows = cRows
Do While cCount <= cSelectedRows - 1
    If Cells(cActiveRow, cSource + 1).Value = Cells(cActiveRow + 1, cSource + 1).Value Then
        Do While Cells(cActiveRow, cSource + 1).Value = Cells(cActiveRow + 1, cSource + 1).Value And cCount <= cSelectedRows
            For i = 0 To UBound(cTarget)
                cTemp = cTarget(i) + 1
                Cells(cActiveRow + 1, cTemp).Value = Cells(cActiveRow, cTemp).Value + Cells(cActiveRow + 1, cTemp).Value
            Next i
            If cRowDelete = vbNo Then
                Cells(cActiveRow, cSource + 1).EntireRow.Delete
            Else
                Cells(cActiveRow, cSource + 1).Delete Shift:=xlUp
                'Cells(cActiveRow, cFirstColumn).Delete Shift:=xlUp
                For i = 0 To UBound(cTarget)
                    cTemp = cTarget(i) + 1
                    Cells(cActiveRow, cTemp).Delete Shift:=xlUp
                Next i
            End If
            cCount = cCount + 1
        Loop
    Else
        cCount = cCount + 1
    End If
    cActiveRow = cActiveRow + 1
    cSelectedRows = cSelectedRows - 1
Loop
'If cRowDelete = vbNo Then
'    Range(Cells(cFirstRow, cFirstColumn), Cells(cLastRow - cCount, cLastColumn + 1)).Select '+1, da neue Spalte mit einbezogen wird
'Else
'    Range(Cells(cFirstRow, cFirstColumn), Cells(cLastRow, cLastColumn + 1)).Select '+1, da neue Spalte mit einbezogen wird
'End If
'Sortieren
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(cFirstRow, cFirstColumn), Cells(cFirstRow, cFirstColumn)), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
    If cRowDelete = vbNo Then
        .SetRange Range(Cells(cFirstRow, cFirstColumn), Cells(cLastRow - cCount, cLastColumn + 1))
    Else
        .SetRange Range(Cells(cFirstRow, cFirstColumn), Cells(cLastRow, cLastColumn + 1))
    End If
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Columns(cFirstColumn).EntireColumn.Delete Shift:=xlToLeft
If cRowDelete = vbNo Then
    Range(Cells(cFirstRow, cFirstColumn), Cells(cLastRow - cCount, cLastColumn)).Select
Else
    Range(Cells(cFirstRow, cFirstColumn), Cells(cLastRow, cLastColumn)).Select
End If
Application.ScreenUpdating = True
End Sub

Ich hoffe, ich konnte dir damit ein wenig weiterhelfen. Es ist zwar nicht ganz ausgereift, aber vielleicht verbesserst du ja noch ein wenig und postest mir dann deine Version ;-)

Gruß TheQuest