Sub DuplikateRaus()
Dim rngDel As Range, rngC As Range
For Each rngC In Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
If Application.CountIf(Range(Cells(2, 1), rngC), rngC.Value) > 1 Then
If rngDel Is Nothing Then
Set rngDel = rngC
Else
Set rngDel = Union(rngDel, rngC)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.Delete shift:=xlUp
'für ganze Zeile:
' If Not rngDel Is Nothing Then rngDel.EntireRow.Delete shift:=xlUp
End Sub
Sub Spezialfilter_und_SummeWenn()
Columns("A:A").Select
Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B9"), Unique:=True
Range("B9").Activate
Do Until ActiveCell.Offset(0, -1).Value = ""
ActiveCell.FormulaLocal = "=ZÄHLENWENN(A:A;" & ActiveCell.Offset(0, -1).Address & ")"
ActiveCell.Offset(1, 0).Activate
Loop
End Sub
Sub DuplikateRaus()
Dim rngDel As Range, rngC As Range
For Each rngC In Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
rngC.Offset(, 1) = Application.CountIf(Columns(1), rngC.Value)
If Application.CountIf(Range(Cells(2, 1), rngC), rngC.Value) > 1 Then
If rngDel Is Nothing Then
Set rngDel = rngC
Else
Set rngDel = Union(rngDel, rngC)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete shift:=xlUp
End Sub