AW: Doppelte löschen - die Effizienteste Methode
11.05.2008 12:51:00
fcs
Hallo Daniel,
deine Prozedur ist wirklich superschnell.
Bei ca. 10000 Datenzeilen mit 98 % doppelten Einträgen benötigt mein Vorschlag auf meinem 8 Jahre alten Notebook (Win98, Office97, Pentium 3, 128 MB Arbeitsspeicher) ca. 100 Sekunden, deine Prozedur ca. 2 bis 3 .
Ich hatte dann meine Prozedur etwas optimiert:
Daten sortieren und dann in einer Schleife Werte vergleichen und doppelte Zellinhalte löschen.
Zum Schluss in einer Anweisung die Zeilen mit leeren Zellen löschen.
Das brachte mich je nach Anzahl der Doppelten runter auf 2 bis 10 Sekunden.
Ich hab dann von dir die Strategie übernommen, alle Hilfsberechnungen direkt in der Tabelle zu machen, und das Ganze zu einer Function umgebaut, die mit Parametern aufgerufen wird. Das funktioniert jetzt super.
Gruß
Franz
Sub DoppelteLoeschen_vValoren()
Dim varMeldung As Variant
varMeldung = DuplikateLoeschen(objWks:=Worksheets("Vergleich"), _
strBereich:="vValoren", bolSort:=True, bolMeldung:=True)
If varMeldung = "" Then
'do nothing
Else
MsgBox varMeldung
End If
End Sub
Sub DoppelteLoeschen_Selektion()
'Zeilen mit doppelten Einträgen in linker Spalte des selektierten Bereichs löschen
Dim varMeldung As Variant, bolSort As Boolean
varMeldung = MsgBox(Prompt:="Soll die vorhandene Sortierung der Zeilen " _
& "beibehalten werden?" _
& vbLf & vbLf & "Bei NEIN wird nach der Spalte mit den Duplikaten sortiert.", _
Buttons:=vbYesNoCancel + vbQuestion, _
Title:="Doppelte Datensätze löschen - in Selektion")
Select Case varMeldung
Case vbYes: bolSort = True
Case vbNo: bolSort = False
Case vbCancel: GoTo Weiter01
End Select
varMeldung = DuplikateLoeschen(objWks:=ActiveSheet, _
strBereich:=Selection.Address, _
bolSort:=bolSort, _
bolMeldung:=True)
If varMeldung "" Then
MsgBox varMeldung
End If
ActiveCell.Select
Weiter01:
End Sub
Public Function DuplikateLoeschen(objWks As Worksheet, strBereich As String, _
Optional bolSort As Boolean = False, _
Optional bolMeldung As Boolean = False) As String
'Tabellen-Zeilen mit Duplikaten in der 1. Spalte des Bereiches entfernen
'objWks = Tabellenblatt in dem die Doppelten entfernt werden sollen
'strBereich = Bereichsname oder Zellbereich
'bolSort = True: Sortierung der Daten in der Tabelle bleibt erhalten _
False: Tabelle wird nach der Duplikate-Spalte sortiert
'bolMeldung = True: Meldung über Anzahl gelöschte Zeilen wird angezeigt _
False: Meldung wird nicht angezeigt
Dim rngData As Range
Dim rngSort As Range
Dim rngVergleich As Range
Dim nRowsDel As Long
Application.ScreenUpdating = False
On Error GoTo Fehler
With objWks
'Duplikate-Bereich setzen
Set rngData = .Range(strBereich)
If rngData.Rows.Count = 1 Then
MsgBox "Der Datenbeich enthält nur eine Zeile, keine Doppelten möglich."
GoTo Beenden
ElseIf Application.WorksheetFunction.CountA(rngData.Columns(1)) = 0 Then
MsgBox "Der Datenbereich enthält keine Daten!"
GoTo Beenden
End If
'2 Hilfs-Spalten links von Spalte A einfügen
.Range(.Columns(1), Columns(2)).Insert shift:=xlShiftToRight
End With
If bolSort = True Then
Set rngSort = rngData.Columns(1).Offset(0, -rngData.Column + 1)
'Formel für Zeilenummer in Sotierbereich einfügen
rngSort.Formula = "=ROW()"
'Formel duch Werte ersetzen
rngSort.Value = rngSort.Value
End If
'Tabellen-Zeilen nach Duplikatespalte sortieren
With rngData
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
End With
'Bereich in 2. Spalte für Vergleich definieren
Set rngVergleich = rngData.Columns(1).Offset(0, -rngData.Column + 2)
'Formel für Zeilenvergleich einfügen, dann durch Werte ersetzen
With rngVergleich
If rngData.Row = 1 Then
'Sonderfall Datenbereich beginnt in 1. Zeile, Vergleichsformel nicht möglich
.Cells(1, 1).Value = rngSort.Cells(1, 1).Value
With objWks.Range(objWks.Cells(2, .Column), objWks.Cells(.Rows.Count, .Column))
.FormulaR1C1 = "=IF(RC" & rngData.Column & "=R[-1]C" _
& rngData.Column & ",TRUE,RC[-1])"
End With
Else
.FormulaR1C1 = "=IF(RC" & rngData.Column & "=R[-1]C" _
& rngData.Column & ",TRUE,RC[-1])"
'Sonderfall Zelle oberhalb Selektion ist identisch mit 1. Wert der Selektion
If rngData.Cells(1, 1).Value = rngData.Cells(1, 1).Offset(-1, 0).Value Then
.Cells(1, 1).Value = rngSort.Cells(1, 1).Value
End If
End If
.Value = .Value
'Anzahl Zeilen vor dem Löschen
nRowsDel = objWks.Cells(objWks.Rows.Count, .Column).End(xlUp).Row
'Zeilen mit Wert WAHR in Vergleichsspalte löschen
'Tabellenzeilen nach Vergleichsspalte sortieren (Sortiert zu löschende ans Ende)
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
'Letzten Eintrag in Vergleichsspalte prüfen und ggf. Zeilen löschen
If objWks.Cells(objWks.Rows.Count, .Column).End(xlUp).Value = True Then
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete shift:=xlShiftUp
End If
'Anzahl gelöschte Zeilen
nRowsDel = nRowsDel - objWks.Cells(objWks.Rows.Count, .Column).End(xlUp).Row
End With
If bolSort = True Then
'Tabellen-Zeilen wieder in alte Reihenfolge sortieren
With rngSort
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
End With
Else
'Tabellen-Zeilen nach Duplikate-Spalte sortieren
With rngData
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
End With
End If
'Hilfsspalten wieder löschen
With objWks
.Range(.Columns(1), .Columns(2)).Delete shift:=xlShiftToLeft
End With
If bolMeldung = True Then
MsgBox Prompt:="Es wurden " & nRowsDel & " doppelte Datensätze gelöscht!", _
Buttons:=vbOKOnly + vbInformation, _
Title:="Doppelte Datensätze löschen"
End If
DuplikateLoeschen = ""
GoTo Beenden
Fehler:
DuplikateLoeschen = "Fehler bei Ausführung der Prozedur ""DuplikateLöschen""" _
& vbLf & vbLf _
& "Fehler Nummer: " & Err.Number & vbLf & Err.Description
If Not rngSort Is Nothing Then
'Hilfsspalten wieder löschen
With objWks
.Range(.Columns(1), .Columns(2)).Delete shift:=xlShiftToLeft
End With
End If
Beenden:
Set rngData = Nothing: Set rngSort = Nothing: Set rngVergleich = Nothing
Application.ScreenUpdating = True
End Function