sorry Nancy, das hatte ich so nicht bedacht *schäm*, hier nun die neue Version, ich hoffe sie entspricht den Regeln besser *grien*
Lieben Gruß
Reinhard
Sub test2()
With Sheets("Tabelle1")
Sheets("Tabelle1").Activate
.Range(Cells(2, 1), Cells(.Range("A65536").End(xlUp).Row, 2)).Copy _
Destination:=Worksheets("Tabelle2").Cells(1, 1)
End With
With Sheets("Tabelle2")
Sheets("Tabelle2").Activate
.Range("C1").FormulaR1C1 = "1"
.Range("C2").FormulaR1C1 = "=IF(RC[-2]=R[-1]C[-2],0,1)"
.Range("C2").Copy
ActiveSheet.Paste Destination:=.Range("C2:C" & .Range("A65536").End(xlUp).Row)
Application.CutCopyMode = False
.Range("C1:C" & .Range("A65536").End(xlUp).Row).Copy
.Range("C1:C7").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.Range("A1:C" & .Range("A65536").End(xlUp).Row).Sort _
Key1:=Range("C1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.CutCopyMode = False
For n = .Range("c65536").End(xlUp).Row To 1 Step -1
If .Cells(n, 3) = 0 Then Rows(n).Delete
Next n
Columns(3).Clear
End With
End Sub