AW: Doppelte löschen
16.08.2017 13:37:03
Werner
Hallo Struppi,
nimm besser den Code. Da habe ich am Anfang noch nach Spalte A sortiert (zur Sicherheit, funktioniert nämlich nur, wenn die Doppler jweils direkt aufeinander folgen) und am Ende wird auch noch mal nach Spalte A sortiert.
Option Explicit
Sub Doppelte_raus()
Dim loZeile As Long
Dim loSpalte As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Tabelle1")
loZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A2:A" & loZeile), SortOn:=xlSortOnValues _
, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range(Cells(2, 1), Cells(loZeile, loSpalte))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Range(.Cells(2, loSpalte + 1), .Cells(loZeile, loSpalte + 1)).FormulaLocal = _
"=WENN(UND(A2=A1;L2="""");1;"""")"
.Range(.Cells(2, loSpalte + 1), .Cells(loZeile, loSpalte + 1)).Value = _
.Range(.Cells(2, loSpalte + 1), .Cells(loZeile, loSpalte + 1)).Value
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range(.Cells(2, loSpalte + 1), .Cells(loZeile, loSpalte + 1)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range(Cells(2, 1), Cells(loZeile, loSpalte + 1))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
loZeile = .Cells(.Rows.Count, loSpalte + 1).End(xlUp).Row
If loZeile > 1 Then
.Range(.Cells(2, 1), .Cells(loZeile, loSpalte + 1)).EntireRow.Delete
loZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A2:A" & loZeile), SortOn:=xlSortOnValues _
, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range(Cells(2, 1), Cells(loZeile, loSpalte))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Else
MsgBox "Keine Doppler vorhanden"
End If
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Gruß Werner