Löschbeschleunigung

Computer: Software & Programmierung Visual Basic
#1

Moin auch,

in einer kleinen Exceldatei mit nur knapp 1.000.000 Zeilen will ich alle die löschen, die in der 3. Spalte ein X tragen.

Code:

Sub delete\_x()
Dim reihe As Long
Application.Screenupdating = False
For reihe = 987654 To 1 Step -1
 If Cells(reihe, 3).Value = "X" Then
 Cells(reihe, 3).EntireRow.Delete shift:=xlUp
 End If
Next
Application.Screenupdating = True
End Sub

Das Makro funktioniert an sich, dauert aber eeeeewig. Wie kann ich denn den Code optimieren, damit das Löschen schneller geht?

Ralph

#2

Grüezi Ralph

Sortiere deine Daten zuerst nach deiner dritten Spalte, ermittle dann mit .Find und durch Zählen wo der Bereich beginnt und wie gross er ist und lösche diesen dann als kompletten Block.

Wenn Du in dieser Spalte sonst keine leeren Zellen drin hast, dann ersetzt das ‚X‘ durch ‚nix‘ und lösche nach dem Sortieren mit SpecialCells(xlCellTypeBlank) alle Zeilen die ‚nix‘ enthalten auf einen Schlag.

Mit freundlichen Grüssen

Thomas Ramel

  • MVP für MS-Excel -
#3

Moin auch,

Ich hätte erwähnen sollen, dass die Reihen aufeinander aufbauen. Der Eintrag in Zelle (10,1) MUSS nach dem Eintrag in Zelle (9,1) stehen. Deswegen funktioniert der an sich nützliche Trick mit dem Sortieren leider nicht.

Ralph

#4

Grüezi Ralph

Ich hätte erwähnen sollen, dass die Reihen aufeinander
aufbauen. Der Eintrag in Zelle (10,1) MUSS nach dem Eintrag in
Zelle (9,1) stehen. Deswegen funktioniert der an sich
nützliche Trick mit dem Sortieren leider nicht.

Mit einer Hilfsspalte kann man ja nach dem Löschen wieder zurück sortieren lassen… :wink:

Mit freundlichen Grüssen

Thomas Ramel

  • MVP für MS-Excel -
#5

Moin auch,

Mit einer Hilfsspalte kann man ja nach dem Löschen wieder
zurück sortieren lassen… :wink:

Eben. Das fiel mir auch eben ein, aber du bist einfach schneller.

Ralph

#6

Das Makro funktioniert an sich, dauert aber eeeeewig. Wie kann
ich denn den Code optimieren, damit das Löschen schneller
geht?

Hallo Ralph,

Sub delete\_x()
Dim reihe As Long
On Error Resume Next
Application.ScreenUpdating = False
With Range("AA1:AA987654")
 .Formula = "=IF(C1=""X"","""",1)"
 .Value = .Value
 .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 .ClearContents
End With
Application.ScreenUpdating = True
End Sub

Gruß
Reinhard

#7

Lösung
Moin auch,

als Aufklärung: Ging nicht! Die Fehlermeldung war von der Art „Excel kann die Aktion mit den vorhandenen Resourcen nicht ausführen“. 600.000 Zeilen waren wohl einfach zuviel. Aber 400.000 Zeilen kopieren, das ging:

Sub delete\_X()
Dim strBereich As String
Dim wksTab1 As Worksheet
 
Set wksTab1 = Sheets("DAT-File2")
strBereich = Range(Cells(136500, 1), Cells(253498, 2)).Address
 
wksTab1.Range(strBereich).Copy
Sheets("Results").Cells(462985, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, \_
 SkipBlanks:=False, Transpose:=False
 
Set wksTab1 = Nothing

End Sub

Ja, ich habe feste Bezüge, was von Übel ist, das geht (mir) aber schneller von der Hand.

Ralph