AW: Doppelte mit Bedingung löschen
11.06.2018 11:53:58
Ludmila
Hallo Zusammen,
habe es jetzt so gelöst, vielleicht nicht der Beste Weg aber es funktioniert.
Private Sub CommandButton1_Click()
Dim lxl&, lol&
With ThisWorkbook.Worksheets("BL")
lol = .Cells(Rows.Count, 3).End(xlUp).Row
.Cells(2, 1).Resize(lol - 1, 7).Sort _
Key1:=.Range("C2"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
.Cells(2, 1).Resize(lol - 1, 7).Sort _
Key1:=.Range("F2"), Order1:=xlDescending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
lol = .Cells(Rows.Count, 3).End(xlUp).Row
For lxl = lol To 1 Step -1
If WorksheetFunction.CountIf(.Columns(3), .Cells(lxl, 3)) > 1 Then
If .Cells(lxl, 7) = "Alt" Then
Rows(lxl).Delete
End If
End If
Next lxl
lol = .Cells(Rows.Count, 3).End(xlUp).Row
.Cells(2, 1).Resize(lol - 1, 7).Sort _
Key1:=.Range("C2"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For lol = 2 To .Cells(Rows.Count, 3).End(xlUp).Row
.Cells(lol, 1) = lol
.Cells(lol, 7) = "Alt"
Next
End With
End Sub