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
cRows = Selection.Rows.Count
cColumns = Selection.Columns.Count
cFirstRow = Selection.Cells.Row
cLastRow = cFirstRow + cRows - 1
cFirstColumn = Selection.Cells.Column
cLastColumn = cFirstColumn + cColumns - 1
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
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
If cTarget(i) < cTemp Then
MsgBox "Mindestens eine der angegebenen Wertespalten befindet sich außerhalb der Auswahl."
Exit Sub
End If
cTemp = cLastColumn
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
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
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
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
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
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