|
Ich hab mir dafür mal die Funktion gebaut:
Function delDupRows(rng As Range, _
Optional ByVal KeyCol1% = 1, _
Optional ByVal KeyCol2% = 1, _
Optional ByVal showMSG As Boolean = True _
) As Long
Dim LV, LV2, AV, R&, d&, U&, E&
Dim t#
With rng
.Sort .Columns(KeyCol1), xlAscending, .Columns(KeyCol2), , xlAscending
AV = .Value
End With
E = UBound(AV)
LV = AV(1, KeyCol1)
LV2 = AV(1, KeyCol2)
U = U + 1
For R = 2 To E
If AV(R, KeyCol1) = "" Then Exit For
If AV(R, KeyCol1) = LV And AV(R, KeyCol2) = LV2 Then
AV(R, KeyCol1) = ""
d = d + 1
Else
LV = AV(R, KeyCol1)
LV2 = AV(R, KeyCol2)
U = U + 1
End If
Next
With rng
.Value = AV
.Sort .Columns(KeyCol1), xlAscending, .Columns(KeyCol2), , xlAscending
If U < .Rows.Count Then .Parent.Range(rng(U + 1, 1), rng(.Rows.Count, .Columns.Count)).Clear
End With
If showMSG Then MsgBox d & " Duplikate entfernt und " & U + 1 & " Unikate behalten."
delDupRows = U
End Function
Könntest du dann z.B. so ausführen:
Sub MaximalZeitwerteFiltern()
Dim rng As Range
Set rng = Selection
With rng
.Sort .Columns(1), xlAscending, .Columns(2), , xlAscending
End With
delDupRows rng, 1
End Sub
|