Daten sortieren, bevor Doppelte gelöscht werden
Peter
Mit nachfolgendem Code kopiere ich aus einer Tabelle ein Range mit verschiedenen Daten (DD.MM.JJJJ) in die Tabelle "Buchungstage". Diese Daten sind nicht sortiert und kommen mehrfach vor.
Vor der Codezeile .EntireRow.Sort Key1:=.Cells(Z1, SP + 2), Order1:=xlAscending, Header:=xlNo
stehen die Daten in Spalte 3 und sollten demnach hier sortiert werden, damit anschliessend von allen Daten nur noch eines (also keine Doppelten) übrig bleibt.
Leider funktioniert die Sortierung nicht; nach Abarbeiten des codes kommen immer noch Daten mehrfach vor.
Wäre toll, wenn mir jemand weiterhelfen könnte.
Danke, Peter
Sub Doppelte_Loeschen()
Dim Z1 As Long, Z2 As Long, SP As Long, c As Range, Ende As Long, lngSpa As Long, Bereich As _
Range
'----Inhalt der Tabelle löschen und Daten zur Bearbeitung hineinkopieren
With Sheets("Buchungstage")
.Cells.ClearContents
With Range("xDatum")
'Werte in Tabelle "Buchungstage"kopieren ab Zelle A2
.Copy Destination:=Sheets("Buchungstage").Range("A2")
End With
'------Position der hineinkopierten Daten bestimmen
Z1 = 2 '1. Zeile mit Daten
SP = 1 'Spalte
Z2 = Sheets("Buchungstage").Cells(65536, 1).End(xlUp).Row 'Letzte Zeile
'--- Hilfsspalten einfügen und Original-Reihenfolge sichern
.Range("A:B").Insert
With .Range(.Cells(Z1, 1), .Cells(Z2, 1))
.FormulaR1C1 = "=Row()"
.Formula = .Value
End With
'--- Doppelte kenzeichnen und loeschen
On Error Resume Next
With .Range(.Cells(Z1, 2), .Cells(Z2, 2))
.EntireRow.Sort Key1:=.Cells(Z1, SP + 2), Order1:=xlAscending, Header:=xlNo
.FormulaR1C1 = "=IF(RC[" & SP & "]=R[-1]C[" & SP & "],TRUE,RC[-1])" 'bei dieser _
Formel fliegen alle Null Werte raus
''.FormulaR1C1 = "=IF(EXACT(RC[" & SP & "],R[-1]C[" & SP & "]),TRUE,RC[-1])" 'bei _
dieser Formel bleibt ein Null-Wert, sofern vorhanden
.Value = .Value
.EntireRow.Sort Key1:=Cells(Z1, 2), Order1:=xlAscending, Header:=xlNo
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
End With
On Error GoTo 0
'--- Aufräumen
.Range("A:B").Delete
Ende = .Cells(65536, 1).End(xlUp).Row 'Letzte Zeile
'-----Range des verbleibenden Datenbereichs benennen
Set Bereich = .Range("A" & Z1, "A" & Ende)
ActiveWorkbook.Names.Add _
Name:="datExtrakt", _
RefersTo:=Bereich, Visible:=True
End With
End Sub