Code:
Option Explicit
Sub Löschen()
Dim i As Long, j As Long
Dim lngS As Long ' die letzte belegte Spalte in Zeile 4
Dim lngZ As Long ' die letzte belegte Zeile in Spalte A
Dim dblS As Double
Dim rngA As Range
On Error GoTo Ende
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Tabelle1")
lngZ = .Cells(Rows.Count, 1).End(xlUp).Row
lngS = .Cells(4, Columns.Count).End(xlToLeft).Column
.Range(.Cells(4, 1), .Cells(lngZ, lngS)).Sort _
Key1:=.Cells(4, 1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
.Range(.Cells(5, lngS + 2), .Cells(lngZ, lngS + 2)).FormulaLocal = "=Wenn(A5<>A4;ZÄHLENWENN(A:A;A5);0)"
For i = 5 To lngZ
If .Cells(i, lngS + 2) > 1 Then
If .Cells(i, 1) = .Cells(i + 1, 1) Then
For j = 2 To lngS
dblS = Application.WorksheetFunction.Sum(.Range(.Cells(i, j), .Cells(i + .Cells(i, lngS + 2) - 1, j)))
If dblS > 0 Then
If Application.Count(.Range(.Cells(i, j), .Cells(i + .Cells(i, lngS + 2) - 1, j))) > 1 Then
.Cells(i, lngS + 1) = 1
If rngA Is Nothing Then
Set rngA = .Cells(i, j)
Else
Set rngA = Union(rngA, .Cells(i, j))
End If
End If
.Cells(i, j) = dblS
End If
Next j
End If
End If
Next i
.Range(.Cells(5, 1), .Cells(lngZ, lngS)).Interior.ColorIndex = xlNone
If Not rngA Is Nothing Then
rngA.Interior.ColorIndex = 3
End If
.Range(.Cells(4, 1), .Cells(lngZ, lngS)).RemoveDuplicates Columns:=1, Header:=xlYes
.Columns(lngS + 2).Clear
If Not rngA Is Nothing Then
lngZ = .Cells(Rows.Count, 1).End(xlUp).Row
lngS = .Cells(4, Columns.Count).End(xlToLeft).Column
.Range(.Cells(4, 1), .Cells(lngZ, lngS)).Sort _
Key1:=.Cells(4, lngS), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
Set rngA = Nothing
End If
End With
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Ende:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err Then MsgBox "Fehler: " & Err.Number & vbLf & vbLf & Err.Description
End Sub
Eigentlich hätte der bisherige gar nicht funktionieren dürfen.
Denn es fehlte vor einigen Cells Angaben der Punkt.
Achte bitte selber auch darauf, vor jeder Range und Cells muss ein Punkt.
Am besten den Code in ein allgemeines Modul einfügen und von dort starten.
Wenn ein Fehler mit "Index ausserhalb...bla.. bla" kommt, dann prüf bitte ob das Blatt "Tabelle1" heißt.