Zeilen mit doppelten Einträgen löschen

und: Zeilen in anderes Blatt kopieren

Oft haben wir große Tabellen, in denen in einer Spalte immer wieder die gleichen Einträge vorkommen. Um die entsprechenden Zeilen bis auf eine zu löschen, kann das folgende VBA-Programm verwendet werden.
Zuerst ist die Tabelle nach der Spalte mit den doppelten Einträgen zu sortieren. Wenn diese nicht in der Spalte "A" stehen, muss das Makro angepasst werden.
Das Makro setzt in Zeile 2 der entsprechenden Spalte an, und vergleicht den Inhalt mit dem in der Zeile darüber stehenden Wert. Ist dieser gleich dem in der aktuellen Zeile, wird diese komplett gelöscht. Auf diese Weise arbeitet sich das Programm Zeile für Zeile weiter nach unten, bis die erste freie Zelle erreicht ist.

Wer Wert auf eine Sicherung der gelöschten Zeilen legt, kann die auskommentierten Programmzeilen einfach aktivieren und muss aber dann die Tabellenblattnamen im Makro anpassen. Das Makro kopiert dann jede gelöschte Zeile in ein anderes Worksheet der gleichen Mappe.

Damit in der Sicherungstabelle keine bestehenden Daten überschrieben werden, erfolgt wärend der Laufzeit eine Prüfung, wo sich die letzte benutze Zeile auf dem Sicherungsblatt befindet. Zwei Methoden dazu sind hier vorgestellt (siehe: "so geht's auch"). Bitte nur jeweils eine davon im Makro aktiv stellen.

Sub doppelte_löschen()
'** zuerst müssen die Zeilen der Tabelle nach der Spalte **
'** sortiert werden, in der die doppelten Werte vorkommen. **
'** Wenn die gelöschten Zeilen zur Sicherheit auf ein **
'** anderes Tabellenblatt kopiert werden sollen, dann **
'** müssen die Tabellenblattnamen ("Tabelle1" und "Tabelle2") **
'** im Makro angepasst, und die jetzt auskommentierten **
'** Zeilen wieder aktiviert werden. **
'** Kommentarzeilen sind mit "** ..... **" gekennzeichnet. **

'Application.ScreenUpdating = False
'Dim Zeile As Double

'-------------------------------------------------------------
'** letzte Zeile in "Tabelle2" finden: **

'Zeile = Worksheets("Tabelle2").UsedRange.Rows.Count
'** so geht's auch: **
''Zeile = Worksheets("Tabelle2").Cells.SpecialCells(xlCellTypeLastCell).Row + 1

'** Eine Zeile Zwischraum zu älteren Daten lassen: **
'If Zeile > 1 Then Zeile = Zeile + 1
'-------------------------------------------------------------

Range("A2").Activate
Do Until ActiveCell.Value = ""
If ActiveCell.Offset(-1, 0).Value = ActiveCell.Value Then
'          ActiveCell.EntireRow.Copy
'          Worksheets("Tabelle2").Cells(Zeile, 1). _
'          PasteSpecial Paste:=xlValues
'          CutCopyMode = False
'          Zeile = Zeile + 1
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop

'Application.ScreenUpdating = True
End Sub