Löschen von Zeilen mit einer Bedingung

Hallo Excel Profis,
mit folgendem Code lösche ich Zeilen mit einer Bedingung:


Sub archiv_bereinigen()
Sheets("Übersichtstabelle").Select
If ActiveSheet.AutoFilterMode Then Cells.AutoFilter
Application.EnableEvents = True
Application.ScreenUpdating = False
e1 = 29000
For i1 = 3 To e1
Sheets("Übersichtstabelle").Select
If i1 Mod 10 = 0 Or i1 = e1 Then
Application.StatusBar = "Archiv bereinigen, Datensatz " & Format(i1, "0000000") & " von " & Format(e1, "0000000") & " Endzeit = " & Anfangszeit1 + (Now() - Anfangszeit1) / i1 * e1
DoEvents
End If
gn_co = Cells(i1, 16)
gn_such = gn_co
If gn_such  "" Then
Do
Set c = Sheets("Archiv").Columns("P:P").Find(gn_such, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
'Datensatz gefunden
y = c.row
'Datensatz löschen
Sheets("Archiv").Select
zelle_spalte = Format(y, "0000000") + ":" + Format(y, "0000000")
Rows(zelle_spalte).Select
Selection.Delete Shift:=xlUp
End If
Loop Until c Is Nothing
End If
Next i1
Application.StatusBar = True
Application.ScreenUpdating = True
End Sub

Anmerkung:
Sheet Übersichtstabelle hat 29.000 Reihen
Sheet Archiv hat 1.100 Reihen
Aus Übersichtstabelle loope ich durch alle Einträge und lese mir eine Zelle raus (gn_co)
Alle Reihen in Archiv mit dieser Bedingung sollen gelöscht werden
Das ganze dauert jedoch zu lange (> 1h); gibt es einen schnelleren Weg?
Danke für Hilfe!
Heinz

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub archiv_bereinigen_2() Dim el As Long Dim il As Long Dim qn_such As Variant Dim fadr As String Dim c As Range Dim x As Range If Sheets("Übersichtstabelle").AutoFilterMode Then Sheets("Übersichtstabelle").Rows(1).AutoFilter Application.EnableEvents = False Application.ScreenUpdating = False e1 = 29000 For i1 = 3 To e1 gn_such = Sheets("Übersichtstabelle").Cells(i1, 16) If gn_such "" Then Set c = Sheets("Archiv").Columns("P:P").Find(gn_such, LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then fadr = c.Address Do 'Datensaetze merken If x Is Nothing Then Set x = c Else Set x = Union(x, c) End If Set c = Sheets("Archiv").Columns("P:P").FindNext(c) Loop Until c.Address = fadr End If End If Next i1 'Datensaetze löschen If Not x Is Nothing Then x.EntireRow.Delete shift:=xlShiftUp Set x = Nothing Application.Goto Sheets("Übersichtstabelle").Cells(1, 1) Application.EnableEvents = False End Sub

1) auch


application.calculation=xlCalculationManual

setzen. sonst werden immer alle offenen Mappen nach Veränderungen gecheckt und ggf neu berechnet
2) bei beibehalten der Logik:
a) Nicht groß einen Bezug mit Format ausrechnen, sondern


c.entirerow.delete

bzw
b) falls es im Archiv normalerweise mehrere Zeilen zu cn_go gibt, das Archiv sortieren, und dann alle Zeilen mit cn_go am Stück löschen
3) Umstellen der Logik:
Nicht die Übersichtstabelle durchlaufen, sondern das Archiv, und zwar von unten nach oben.
evtl. Delete durch Clear ersetzen, und am Schluss die Tabelle wieder sortieren - Delete muß alle nachfolgenden Zellen unter Beachtung von
Bezügen verschieben, das kann dauern
Da die internen Funktionen effizienter sind als der VBA-interpreter, dürfte es schneller sein 1.000mal einen Wert in 30.000 Zeilen zu suchen, als 30.000mal einen Wert in 1.000 Zeilen zu suchen

Beliebteste Forumthreads (12 Monate)

Löschen von Zeilen mit einer Bedingung

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Löschen von Zeilen mit einer Bedingung

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread