Sub Gleiche_weg()
On Error GoTo Fehler
Dim TB As Worksheet
Dim Sp As Integer, LR As Long, LC As Integer
Const APPNAME = "Gleiche_weg"
Application.ScreenUpdating = False
Set TB = Sheets("Tabelle1")
Sp = 1
With TB
If .AutoFilterMode Then .AutoFilterMode = False
LR = .Cells(.Rows.Count, Sp).End(xlUp).Row
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Cells(1, LC + 2) = "Temp"
.Cells(1, LC + 3) = "Anzahl"
.Cells(1, LC + 4) = "Wiederholung"
.Cells(2, LC + 2).Resize(LR - 1, 1).FormulaR1C1 = "=RC[-4]&""|""&RC[-3]"
.Cells(2, LC + 3).Resize(LR - 1, 1).FormulaR1C1 = "=COUNTIF(C[-1],RC[-1])"
.Cells(2, LC + 4).Resize(LR - 1, 1).FormulaR1C1 = "=COUNTIF(R2C[-6]:RC[-6],RC[-6])"
.Columns(LC + 3).AutoFilter Field:=1, Criteria1:=">1"
.Cells(1, 1).CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilterMode = False
.Columns(LC + 4).AutoFilter Field:=1, Criteria1:=">1"
Intersect(.Cells(1, 1).CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow, .Columns(1)).ClearContents
.AutoFilterMode = False
.Columns(LC + 2).Resize(, 3).Delete
End With
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number <> 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub