web-dev-qa-db-de.com

Excel VBA-Leistung - 1 Million Zeilen - Löschen Sie Zeilen mit einem Wert in weniger als 1 Minute

Ich versuche einen Weg zu finden, große Daten in weniger als einer Minute zu filtern und Zeilen in einem Arbeitsblatt zu entfernen

Das Ziel:

  • Suchen Sie alle Datensätze, die bestimmten Text in Spalte 1 enthalten, und löschen Sie die gesamte Zeile
  • Behalten Sie die Zellformatierung (Farben, Schriftarten, Ränder, Spaltenbreiten) und Formeln bei

.

Testdaten:

Test data:

.

Wie der Code funktioniert:

  1. Zunächst werden alle Excel-Funktionen deaktiviert
  2. Wenn die Arbeitsmappe nicht leer ist und der zu entfernende Textwert in Spalte 1 vorhanden ist

    • Kopiert den verwendeten Bereich von Spalte 1 in ein Array
    • Iteriert über jeden Wert im Array rückwärts
    • Wenn es eine Übereinstimmung findet:

      • Hängt die Zellenadresse an eine tmp-Zeichenfolge im Format "A11,A275,A3900,..." an
      • Wenn die Variable tmp fast 255 Zeichen lang ist
      • Löscht Zeilen mit .Range("A11,A275,A3900,...").EntireRow.Delete Shift:=xlUp
      • Setzt tmp auf leer zurück und fährt mit den nächsten Zeilen fort
  3. Am Ende werden alle Excel-Funktionen wieder aktiviert

.

Das Hauptproblem ist der Löschvorgang, und die Gesamtdauer sollte unter einer Minute liegen. Jede Code-basierte Lösung ist akzeptabel, solange sie weniger als 1 Minute dauert.

Dies beschränkt den Anwendungsbereich auf sehr wenige akzeptable Antworten. Die bereits gegebenen Antworten sind auch sehr kurz und leicht umzusetzen. Eins führt die Operation in etwa 30 Sekunden durch, daher gibt es mindestens eine Antwort, die eine akzeptable Lösung liefert, und andere können es ebenfalls nützlich finden

.

Meine Hauptfunktion:

Sub DeleteRowsWithValuesStrings()
    Const MAX_SZ As Byte = 240

    Dim i As Long, j As Long, t As Double, ws As Worksheet
    Dim memArr As Variant, max As Long, tmp As String

    Set ws = Worksheets(1)
    max = GetMaxCell(ws.UsedRange).Row
    FastWB True:    t = Timer

    With ws
        If max > 1 Then
            If IndexOfValInRowOrCol("Test String", , ws.UsedRange) > 0 Then
                memArr = .Range(.Cells(1, 1), .Cells(max, 1)).Value2
                For i = max To 1 Step -1

                    If memArr(i, 1) = "Test String" Then
                        tmp = tmp & "A" & i & ","
                        If Len(tmp) > MAX_SZ Then
                           .Range(Left(tmp, Len(tmp) - 1)).EntireRow.Delete Shift:=xlUp
                           tmp = vbNullString

                        End If
                    End If

                Next
                If Len(tmp) > 0 Then
                    .Range(Left(tmp, Len(tmp) - 1)).EntireRow.Delete Shift:=xlUp
                End If
                .Calculate
            End If
        End If
    End With
    FastWB False:   InputBox "Duration: ", "Duration", Timer - t
End Sub

Hilfsfunktionen (Excel-Funktionen ein- und ausschalten):

Public Sub FastWB(Optional ByVal opt As Boolean = True)
    With Application
        .Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
        .DisplayAlerts = Not opt
        .DisplayStatusBar = Not opt
        .EnableAnimations = Not opt
        .EnableEvents = Not opt
        .ScreenUpdating = Not opt
    End With
    FastWS , opt
End Sub

Public Sub FastWS(Optional ByVal ws As Worksheet = Nothing, _
                  Optional ByVal opt As Boolean = True)
    If ws Is Nothing Then
        For Each ws In Application.ActiveWorkbook.Sheets
            EnableWS ws, opt
        Next
    Else
        EnableWS ws, opt
    End If
End Sub

Private Sub EnableWS(ByVal ws As Worksheet, ByVal opt As Boolean)
    With ws
        .DisplayPageBreaks = False
        .EnableCalculation = Not opt
        .EnableFormatConditionsCalculation = Not opt
        .EnablePivotTable = Not opt
    End With
End Sub

Findet die letzte Zelle mit Daten (danke @ZygD - jetzt habe ich sie in mehreren Szenarien getestet):

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range

    'Returns the last cell containing a value, or A1 if Worksheet is empty

    Const NONEMPTY As String = "*"
    Dim lRow As Range, lCol As Range

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
    If WorksheetFunction.CountA(rng) = 0 Then
        Set GetMaxCell = rng.Parent.Cells(1, 1)
    Else
        With rng
            Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                        After:=.Cells(1, 1), _
                                        SearchDirection:=xlPrevious, _
                                        SearchOrder:=xlByRows)
            If Not lRow Is Nothing Then
                Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                            After:=.Cells(1, 1), _
                                            SearchDirection:=xlPrevious, _
                                            SearchOrder:=xlByColumns)

                Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
            End If
        End With
    End If
End Function

Gibt den Index einer Übereinstimmung im Array zurück oder 0, wenn keine Übereinstimmung gefunden wird:

Public Function IndexOfValInRowOrCol( _
                                    ByVal searchVal As String, _
                                    Optional ByRef ws As Worksheet = Nothing, _
                                    Optional ByRef rng As Range = Nothing, _
                                    Optional ByRef vertical As Boolean = True, _
                                    Optional ByRef rowOrColNum As Long = 1 _
                                    ) As Long

    'Returns position in Row or Column, or 0 if no matches found

    Dim usedRng As Range, result As Variant, searchRow As Long, searchCol As Long

    result = CVErr(9999) '- generate custom error

    Set usedRng = GetUsedRng(ws, rng)
    If Not usedRng Is Nothing Then
        If rowOrColNum < 1 Then rowOrColNum = 1
        With Application
            If vertical Then
                result = .Match(searchVal, rng.Columns(rowOrColNum), 0)
            Else
                result = .Match(searchVal, rng.Rows(rowOrColNum), 0)
            End If
        End With
    End If
    If IsError(result) Then IndexOfValInRowOrCol = 0 Else IndexOfValInRowOrCol = result
End Function

.

Update:

Getestete 6 Lösungen (je 3 Tests): Die Lösung von Excel Hero ist die schnellste bis jetzt (entfernt Formeln)

.

Hier sind die Ergebnisse, vom schnellsten zum langsamsten:

.

Test 1. Insgesamt 100.000 Datensätze, 10.000 zu löschen:

1. ExcelHero()                    - 1.5 seconds

2. DeleteRowsWithValuesNewSheet() - 2.4 seconds

3. DeleteRowsWithValuesStrings()  - 2.45 minutes
4. DeleteRowsWithValuesArray()    - 2.45 minutes
5. QuickAndEasy()                 - 3.25 minutes
6. DeleteRowsWithValuesUnion()    - Stopped after 5 minutes

.

Test 2. Insgesamt 1 Million Datensätze, 100.000 zu löschen:

1. ExcelHero()                    - 16 seconds (average)

2. DeleteRowsWithValuesNewSheet() - 33 seconds (average)

3. DeleteRowsWithValuesStrings()  - 4 hrs 38 min (16701.375 sec)
4. DeleteRowsWithValuesArray()    - 4 hrs 37 min (16626.3051757813 sec)
5. QuickAndEasy()                 - 5 hrs 40 min (20434.2104492188 sec)
6. DeleteRowsWithValuesUnion()    - N/A

.

Anmerkungen:

  1. ExcelHero-Methode: Einfach zu implementieren, zuverlässig, extrem schnell, entfernt jedoch Formeln
  2. NewSheet-Methode: einfach zu implementieren, zuverlässig und erfüllt das Ziel
  3. Strings-Methode: Mehr Aufwand bei der Implementierung, zuverlässig, erfüllt jedoch nicht die Anforderungen
  4. Array-Methode: Ähnlich wie Strings, aber ReDims ein Array (schnellere Version von Union)
  5. QuickAndEasy: Einfach zu implementieren (kurz, zuverlässig und elegant), erfüllt jedoch nicht die Anforderungen
  6. Range Union: Implementierungskomplexität ähnlich wie 2 und 3, jedoch zu langsam

Ich habe die Testdaten auch durch die Einführung ungewöhnlicher Werte realistischer gemacht:

  • leere Zellen, Bereiche, Zeilen und Spalten
  • sonderzeichen wie = [`~! @ # $% ^ & * () _- + {} []\|;: '",. <> /?, getrennte und mehrere Kombinationen
  • leerzeichen, Tabulatoren, leere Formeln, Rahmen, Schriftart und andere Zellformatierungen
  • große und kleine Zahlen mit Dezimalzahlen (= 12.9999999999999 + 0,00000000000000001)
  • hyperlinks, bedingte Formatierungsregeln
  • leere Formatierung innerhalb und außerhalb von Datenbereichen
  • alles andere, was zu Datenproblemen führen könnte
31
paul bica

Ich gebe die erste Antwort als Referenz

Andere finden es nützlich, wenn keine anderen Optionen verfügbar sind

  • Der schnellste Weg zum Erreichen des Ergebnisses besteht darin, den Löschvorgang nicht zu verwenden
  • Aus 1 Million Datensätzen werden 100.000 Zeilen im Durchschnitt von 33 Sekunden entfernt.

.

Sub DeleteRowsWithValuesNewSheet()  '100K records   10K to delete
                                    'Test 1:        2.40234375 sec
                                    'Test 2:        2.41796875 sec
                                    'Test 3:        2.40234375 sec
                                    '1M records     100K to delete
                                    'Test 1:        32.9140625 sec
                                    'Test 2:        33.1484375 sec
                                    'Test 3:        32.90625   sec
    Dim oldWs As Worksheet, newWs As Worksheet, rowHeights() As Long
    Dim wsName As String, t As Double, oldUsedRng As Range

    FastWB True:    t = Timer

    Set oldWs = Worksheets(1)
    wsName = oldWs.Name

    Set oldUsedRng = oldWs.Range("A1", GetMaxCell(oldWs.UsedRange))

    If oldUsedRng.Rows.Count > 1 Then                           'If sheet is not empty
        Set newWs = Sheets.Add(After:=oldWs)                    'Add new sheet
        With oldUsedRng
            .AutoFilter Field:=1, Criteria1:="<>Test String"
            .Copy                                               'Copy visible data
        End With
        With newWs.Cells
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteAll                            'Paste data on new sheet
            .Cells(1, 1).Select                                 'Deselect paste area
            .Cells(1, 1).Copy                                   'Clear Clipboard
        End With
        oldWs.Delete                                            'Delete old sheet
        newWs.Name = wsName
    End If
    FastWB False:   InputBox "Duration: ", "Duration", Timer - t
End Sub

.

Auf hohem Niveau:

  • Es erstellt ein neues Arbeitsblatt und enthält einen Verweis auf das Ausgangsblatt
  • AutoFilters-Spalte 1 im gesuchten Text: .AutoFilter Field:=1, Criteria1:="<>Test String"
  • Kopiert alle (sichtbaren) Daten vom Ausgangsblatt
  • Fügt Spaltenbreiten, -formate und -daten in das neue Blatt ein
  • Löscht das Ausgangsblatt
  • Benennt das neue Blatt in den alten Blattnamen um

Es verwendet die gleichen Hilfsfunktionen, die in der Frage veröffentlicht wurden

Die 99% der Dauer werden vom AutoFilter verwendet

.

Es gibt ein paar Einschränkungen, die ich bisher gefunden habe, die erste kann angesprochen werden:

  1. Wenn sich auf dem ursprünglichen Blatt verborgene Zeilen befinden, werden diese eingeblendet

    • Um sie wieder zu verbergen, ist eine separate Funktion erforderlich
    • Je nach Implementierung kann die Dauer erheblich verlängert werden
  2. VBA bezogen:

    • Der Code-Name des Arbeitsblatts wird geändert. andere VBA, die sich auf Sheet1 beziehen, werden beschädigt (falls vorhanden)
    • Es löscht den gesamten VBA-Code, der dem Ausgangsblatt zugeordnet ist (falls vorhanden).

.

Ein paar Anmerkungen zur Verwendung großer Dateien wie folgt:

  • Das Binärformat (.xlsb) reduziert die Dateigröße drastisch (von 137 MB auf 43 MB).
  • Nicht verwaltete bedingte Formatierungsregeln können zu exponentiellen Leistungsproblemen führen

    • Dasselbe gilt für Kommentare und Datenvalidierung
  • Das Lesen von Dateien oder Daten aus dem Netzwerk ist viel langsamer als das Arbeiten mit einer lokalen Datei

14
paul bica

Ein signifikanter Geschwindigkeitsgewinn kann erzielt werden, wenn die Quelldaten keine Formeln enthalten oder wenn das Szenario die Umwandlung der Formeln in harte Werte während der bedingten Zeilenlöschungen zulässt (oder nicht zulässt).

Mit dem Vorstehenden als Vorbehalt verwendet meine Lösung den AdvancedFilter des Bereichsobjekts. Es ist ungefähr doppelt so schnell wie DeleteRowsWithValuesNewSheet ().

Public Sub ExcelHero()
    Dim t#, crit As Range, data As Range, ws As Worksheet
    Dim r&, fc As Range, lc As Range, fr1 As Range, fr2 As Range
    FastWB True
    t = Timer

        Set fc = ActiveSheet.UsedRange.Item(1)
        Set lc = GetMaxCell
        Set data = ActiveSheet.Range(fc, lc)
        Set ws = Sheets.Add
        With data
            Set fr1 = data.Worksheet.Range(fc, fc.Offset(, lc.Column))
            Set fr2 = ws.Range(ws.Cells(fc.Row, fc.Column), ws.Cells(fc.Row, lc.Column))
            With fr2
                fr1.Copy
                .PasteSpecial xlPasteColumnWidths: .PasteSpecial xlPasteAll
                .Item(1).Select
            End With
            Set crit = .Resize(2, 1).Offset(, lc.Column + 1)
            crit = [{"Column 1";"<>Test String"}]
            .AdvancedFilter xlFilterCopy, crit, fr2
            .Worksheet.Delete
        End With

    FastWB False
    r = ws.UsedRange.Rows.Count
    Debug.Print "Rows: " & r & ", Duration: " & Timer - t & " seconds"
End Sub
9
Excel Hero

Auf meinem älteren Dell Inspiron 1564 (Win 7 Office 2007) Folgendes:

Sub QuickAndEasy()
    Dim rng As Range
    Set rng = Range("AA2:AA1000001")
    Range("AB1") = Now
    Application.ScreenUpdating = False
        With rng
            .Formula = "=If(A2=""Test String"",0/0,A2)"
            .Cells.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
            .Clear
        End With
    Application.ScreenUpdating = True
    Range("AC1") = Now
End Sub

es dauerte ungefähr 10 Sekunden, um zu laufen. Ich gehe davon aus, dass die SpalteAAverfügbar ist.

BEARBEITEN # 1:

Bitte beachten Sie, dass dieser Code nicht Calculation auf Manual setzt. Die Leistung wird verbessert, wenn der Berechnungsmodus auf Manual after gesetzt ist und die Spalte "Helfer" die Berechnung zulässt.

5
Gary's Student

Ich weiß, ich bin mit meiner Antwort hier sehr spät dran, aber zukünftige Besucher könnten es sehr nützlich finden.

Bitte beachten Sie: Mein Ansatz erfordert eine Indexspalte, damit die Zeilen in der ursprünglichen Reihenfolge enden. Wenn Sie jedoch nicht daran denken, dass sich die Zeilen in einer anderen Reihenfolge befinden, ist keine Indexspalte und die zusätzliche Zeile von erforderlich Code kann entfernt werden.

Mein Ansatz: Mein Ansatz bestand darin, einfach alle Zeilen im ausgewählten Bereich (Spalte) auszuwählen, sie mit Range.Sort in aufsteigender Reihenfolge zu sortieren und dann den ersten und letzten Index von "Test String" innerhalb des ausgewählten Bereichs (Spalte) zu sammeln. Ich erstelle dann einen Bereich aus den ersten und letzten Indizes und verwende Range.EntrieRow.Delete, um alle Zeilen zu entfernen, die "Test String" enthalten.

Pros:  
- Es brennt schnell. 
- Formatierungen, Formeln, Diagramme, Bilder oder ähnliches wie die Methode, die auf ein neues Blatt kopiert wird, werden nicht entfernt. 

Nachteile:  
- Eine anständige Größe des zu implementierenden Codes, jedoch alles unkompliziert. 

Test Range Generation Sub:

Sub DevelopTest()
    Dim index As Long
    FastWB True
    ActiveSheet.UsedRange.Clear
    For index = 1 To 1000000 '1 million test
        ActiveSheet.Cells(index, 1).Value = index
        If (index Mod 10) = 0 Then
            ActiveSheet.Cells(index, 2).Value = "Test String"
        Else
            ActiveSheet.Cells(index, 2).Value = "Blah Blah Blah"
        End If
    Next index
    Application.StatusBar = ""
    FastWB False
End Sub

Zeilen filtern und löschen Sub:

Sub DeleteRowFast()
    Dim curWorksheet As Worksheet 'Current worksheet vairable

    Dim rangeSelection As Range   'Selected range
    Dim startBadVals As Long      'Start of the unwanted values
    Dim endBadVals As Long        'End of the unwanted values
    Dim strtTime As Double        'Timer variable
    Dim lastRow As Long           'Last Row variable
    Dim lastColumn As Long        'Last column variable
    Dim indexCell As Range        'Index range start
    Dim sortRange As Range        'The range which the sort is applied to
    Dim currRow As Range          'Current Row index for the for loop
    Dim cell As Range             'Current cell for use in the for loop

    On Error GoTo Err
        Set rangeSelection = Application.InputBox("Select the (N=) range to be checked", "Get Range", Type:=8)    'Get the desired range from the user
        Err.Clear

    M1 = MsgBox("This is recommended for large files (50,000 or more entries)", vbYesNo, "Enable Fast Workbook?") 'Prompt the user with an option to enable Fast Workbook, roughly 150% performace gains... Recommended for incredibly large files
    Select Case M1
        Case vbYes
            FastWB True  'Enable fast workbook
        Case vbNo
            FastWB False 'Disable fast workbook
    End Select

    strtTime = Timer     'Begin the timer

    Set curWorksheet = ActiveSheet
    lastRow = CLng(rangeSelection.SpecialCells(xlCellTypeLastCell).Row)
    lastColumn = curWorksheet.Cells(1, 16384).End(xlToLeft).Column

    Set indexCell = curWorksheet.Cells(1, 1)

    On Error Resume Next

    If rangeSelection.Rows.Count > 1 Then 'Check if there is anything to do

        lastVisRow = rangeSelection.Rows.Count

        Set sortRange = curWorksheet.Range(indexCell, curWorksheet.Cells(curWorksheet.Rows(lastRow).Row, 16384).End(xlToLeft)) 'Set the sort range

        sortRange.Sort Key1:=rangeSelection.Cells(1, 1), Order1:=xlAscending, Header:=xlNo 'Sort by values, lowest to highest

        startBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, MatchCase:=False).Row
        endBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=False).Row

        curWorksheet.Range(curWorksheet.Rows(startBadVals), curWorksheet.Rows(endBadVals)).EntireRow.Delete 'Delete uneeded rows, deleteing in continuous range blocks is quick than seperated or individual deletions.

        sortRange.Sort Key1:=indexCell, Order1:=xlAscending, Header:=xlNo 'Sort by index instead of values, lowest to highest
    End If

    Application.StatusBar = ""                    'Reset the status bar

    FastWB False                                  'Disable fast workbook

    MsgBox CStr(Round(Timer - strtTime, 2)) & "s" 'Display duration of task

Err:
    Exit Sub

End Sub

DIESER CODE VERWENDET FastWB, FastWS UND EnableWS VON Paul Bica!

Zeiten bei 100.000 Einträgen (10.000 werden entfernt, FastWB True):  
1. 0,2 Sekunden. 
2. 0,2 Sekunden. 
3. 0,21 Sekunden. 
Durchschn. 0,2 Sekunden. 

Zeiten bei 1 Million Einträgen (zu entfernende 100k, FastWB True):  
1. 2,3 Sekunden. 
2. 2,32 Sekunden. 
3. 2,3 Sekunden. 
Durchschn. 2,31 Sekunden. 

Läuft auf: Windows 10, iMac i3 11,2 (Ab 2010)

EDIT 
Dieser Code wurde ursprünglich mit dem Zweck entworfen, numerische Werte außerhalb eines numerischen Bereichs herauszufiltern, und wurde angepasst, um "Test String" herauszufiltern, so dass ein Teil des Codes möglicherweise redundant ist.

1
user2693587

Die Verwendung von Arrays zur Berechnung des verwendeten Bereichs und der Zeilenanzahl kann die Leistung beeinträchtigen. Hier ist ein weiterer Ansatz, der sich beim Testen über 1m + Datenzeilen als effizient erweist - zwischen 25 und 30 Sekunden. Es werden keine Filter verwendet, also werden Zeilen gelöscht, selbst wenn sie ausgeblendet sind. Das Löschen einer ganzen Zeile wirkt sich nicht auf die Formatierung oder Spaltenbreite der übrigen verbleibenden Zeilen aus. 

  1. Prüfen Sie zunächst, ob das ActiveSheet "Test String" enthält. Da Sie nur an Spalte 1 interessiert sind, habe ich Folgendes verwendet:

    TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
    If TCount > 0 Then
    
  2. Anstatt Ihre GetMaxCell () - Funktion zu verwenden, habe ich einfach Cells.SpecialCells(xlCellTypeLastCell).Row verwendet, um die letzte Zeile zu erhalten: 

    EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
    
  3. Dann durchlaufen Sie die Datenzeilen:

    While r <= EndRow
    
  4. So testen Sie, ob die Zelle in Spalte 1 gleich "Testzeichenfolge" ist:

    If sht.Cells(r, 1).Text) = "Test String" Then
    
  5. So löschen Sie die Zeile: 

    Rows(r).Delete Shift:=xlUp
    

Der vollständige Code ist unten aufgeführt. Ich habe ActiveSheet auf eine Variable Sht gesetzt und die Verwendung von ScreenUpdating hinzugefügt, um die Effizienz zu verbessern. Da es sich um viele Daten handelt, stelle ich sicher, dass am Ende Variablen gelöscht werden. 

Sub RowDeleter()
    Dim sht As Worksheet
    Dim r As Long
    Dim EndRow As Long
    Dim TCount As Long
    Dim s As Date
    Dim e As Date

    Application.ScreenUpdating = True
    r = 2       'Initialise row number
    s = Now     'Start Time
    Set sht = ActiveSheet
    EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row

    'Check if "Test String" is found in Column 1
    TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
    If TCount > 0 Then

        'loop through to the End row
        While r <= EndRow
            If InStr(sht.Cells(r, 1).Text, "Test String") > 0 Then
                sht.Rows(r).Delete Shift:=xlUp
                r = r - 1
            End If
            r = r + 1
        Wend
    End If
    e = Now  'End Time
    D = (Hour(e) * 360 + Minute(e) * 60 + Second(e)) - (Hour(s) * 360 + Minute(s) * 60 + Second(s))
    Application.ScreenUpdating = True
    DurationTime = TimeSerial(0, 0, D)
    MsgBox Format(DurationTime, "hh:mm:ss")
End Sub
0
Andrew Toomey