Hallo,
naja, die miserable Performance kommt von dir ;-).
Jeder Zugriff auf das Tabellenblatt benötigt sehr viel Zeit, also jedes Cells() noch mehr jedes Rows().delete. Das sind wahnsinnige Zeitfresser.
Drüber hinaus hat dein Code in meinen Augen zwei Logikfehler:
1. du veränderst nicht die Variable i, oder ist das Absicht? Dadurch landest du in einer Endlosschleife und vergleichst immer wieder alle Zeilen mit der ersten??
2. wenn du Zeile 3 löscht, dann wird Zeile 4 zur neuen Zeile 3. Das berücksichtigt dein Code nicht.
Ich habe versucht, deine Vorgehensweise in großen Teilen zu erhalten, gehe aber dennoch ganz anders vor:
Zunächst: ich gehe davon aus, dass dein "Usedrange" Zeile 1 und Spalte A beinhaltet!!
Ich lese das gesamte Tabellenblatt in ein Array (Ar) ein. Die Auslagerung des Vergleiches in die Funktion "Kontrolle" musste ich wieder eingliedern, denn dann kann man sich das häufige füllen der Variablen txA ersparen.
Ein zweites Array (arDel) benutze ich, um mir zu merken, welche Zeilen gelöscht werden sollen (eine 0 bedeutet löschen).
Habe ich alle Zeilen verglichen, trage ich dieses Array "arDel" ins Tabellenblatt in die erste freie Spalte ein und sortiere das gesamte Tabellenblatt nach ihr. Dadurch sind alle zu löschenden Zeilen oben und die Reihenfolge der anderen Zeilen hat sich nicht verändert. Dann kann ich alle Zeilen auf einmal löschen (das spart immens viel Zeit!).
Hier der Code :
Sub DoppelteEinträgeLöschen()
' ###Variablen###
Dim txA As String, txB As String
Dim lRowMaxI As Long, i As Long, j As Long
Dim Ar As Variant, arDel() As Variant
Dim rngLast As Range, lColMax As Long
' ###Sachen abschalten die es nicht braucht###
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Sheets(1)
'Alle Daten in ein Array
Ar = Range(.Cells(1, 1), .UsedRange.SpecialCells(xlCellTypeLastCell)).Value
ReDim arDel(1 To UBound(Ar), 1 To 1)
For j = 1 To UBound(Ar)
arDel(j, 1) = j
Next
lRowMaxI = UBound(Ar)
lColMax = UBound(Ar, 2)
i = 2
Do
txA = Ar(i, 1) & Ar(i, 2) & Ar(i, 3) & Ar(i, 4) & Ar(i, 5) & Ar(i, 6) & Ar(i, 7) & Ar(i, 8)
j = i
Do
j = j + 1
txB = Ar(j, 1) & Ar(j, 2) & Ar(j, 3) & Ar(j, 4) & Ar(j, 5) & Ar(j, 6) & Ar(j, 7) & Ar(j, 8)
If txA = txB Then
arDel(j, 1) = 0 'zum Löschen merken
End If
Loop Until j = lRowMaxI
i = i + 1
Loop Until i = lRowMaxI - 1
'Ergebnis in das Tabellenblatt in eine Hilfsspalte eintragen
.Cells(1, lColMax + 1).Resize(UBound(Ar), 1) = arDel
'sortieren
sortiereBlatt lColMax + 1, .Range("A1").Parent, xlNo
'alle Zeilen, in denen die 0 steht in einem Rutsch löschen
With .Columns(lColMax + 1)
'Letzte Zeile mit der 0 finden
Set rngLast = .Find(0, .Cells(1, 1), LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious)
'löschen, falls es was zu löschen gibt
If Not rngLast Is Nothing Then
.Range(.Cells(1, rngLast.Row), rngLast).EntireRow.Delete
End If
'Hilfsspalte löschen
.Delete
End With
End With
' Sachen wieder einschalten - Performance
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub sortiereBlatt(lCol As Long, Ws As Worksheet, Optional hasHeader As XlYesNoGuess = xlYes)
Dim rngAll As Range
With Ws
Set rngAll = .Range(.Cells(1, 1), .UsedRange.SpecialCells(xlCellTypeLastCell))
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Columns(lCol), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With .Sort
.SetRange rngAll
.Header = hasHeader
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Bitte an Testdaten testen.
ich empfehle dir, hier einen Haltepunkt (Im VBE F9 drücken) zu setzen:
'Ergebnis in das Tabellenblatt in eine Hilfsspalte eintragen
.Cells(1, lColMax + 1).Resize(UBound(Ar), 1) = arDel
Und dann im Einzelschritt mit F8 die nächsten Befehle auszuführen. Dabei in der anderen Bildschirmhälfte schauen, was im Tabellenblatt passiert. Dann verstehst du vielleicht besser, was der code macht.
Was sagst du dazu?
Wie ist die Laufzeit, bei wie vielen Datensätzen?
Grüße, Ulrich
|