Excel VBA Performance - 1 million de lignes - supprimer les lignes contenant une valeur, en moins de 1 min

un gain significatif de vitesse peut être obtenu si les données source ne contiennent pas de formules, ou si le scénario permettrait (ou voudrait) que les formules soient converties en valeurs dures pendant les suppressions de lignes conditionnelles.

avec la mise en garde ci-dessus, ma solution utilise le filtre avancé de l'objet range. C'est environ deux fois plus rapide que 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

Sur mes vieux Dell Inspiron 1564 (Win 7 Office 2007):

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

a pris environ 10 secondes pour s'exécuter. Je suis en supposant que la colonne AA est disponible.

EDIT#1:

Veuillez noter que ce code n' set Calcul Manuel. Les performances s'amélioreront si le mode de calcul est réglé à Manuel après la colonne" helper " permet de calculer.

je sais que je suis incroyablement en retard avec ma réponse ici, mais les futurs visiteurs pourraient la trouver très utile.

Remarque: Mon approche nécessite une colonne d'index pour les lignes à l'extrémité de la commande d'origine, cependant, si vous n'avez pas l'esprit les lignes dans un ordre différent, puis une colonne d'index n'est pas nécessaire, et la ligne de code supplémentaire peut être retiré.

Mon approche: mon approche était simplement de sélectionner toutes les lignes dans les rang (colonne), les trier dans l'ordre croissant en utilisant Range.Sort et puis la collecte du premier et du dernier index de "Test String" dans la plage sélectionnée (colonne). J'ai ensuite créer une gamme à partir de la première et de la dernière indices et utiliser Range.EntrieRow.Delete pour supprimer toutes les lignes qui contiennent "Test String".

Avantages:

- Il est très rapide.

- Il ne supprime pas le formatage, les formules, les graphiques, les images ou n'importe quoi comme la méthode qui copie à une nouvelle feuille.

contre:

- Une taille décente de code à mettre en œuvre mais tout est simple.

Plage De Test De Génération De Sous:

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

Filtrer Et Supprimer Les Lignes 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

CE CODE UTILISE FastWB,FastWS et EnableWS par Paul Bica!

fois à 100k entrées (10k à supprimer, FastWB Vrai):

1. 0,2 secondes.

2. 0,2 secondes.

3. 0.21 secondes.

Avg. 0,2 secondes.

Fois à 1 million d'entrées (100k à être supprimé, FastWB Vrai):

1. 2.3 secondes.

2. 2.32 secondes.

3. 2.3 secondes.

Avg. 2.31 secondes.

tournant sous Windows 10, iMac i3 11,2 (À partir de 2010)

EDIT

Ce code a été conçu à l'origine avec le but de filtrer les valeurs numériques à l'extérieur d'une plage de nombres et a été adapté pour filtrer "Test String" donc le code peut être redondante.

votre utilisation des tableaux dans le calcul de la portée utilisée et le nombre de lignes peut affecter la performance. Voici une autre approche qui dans les essais se révèle efficace à travers 1m + rangées de données - entre 25-30 secondes. Il n'utilise pas de filtres donc supprimera les lignes même si elles sont cachées. La suppression d'une ligne entière n'aura pas d'effet sur le formatage ou la largeur des colonnes des autres lignes restantes.

1. tout d'abord, vérifiez si la feuille D'activation contient "test String". Puisque vous êtes seulement intéressé par la colonne 1 j'ai utilisé ceci:

   TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
   If TCount > 0 Then
   

2. au lieu d'utiliser votre fonction GetMaxCell() j'ai simplement utilisé Cells.SpecialCells(xlCellTypeLastCell).Row pour obtenir la dernière ligne:

   EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
   

3. puis boucle les lignes de données:

   While r <= EndRow
   

4. pour vérifier si la cellule de la colonne 1 est égale à"test String":

   If sht.Cells(r, 1).Text) = "Test String" Then
   

5. supprimer la ligne:

   Rows(r).Delete Shift:=xlUp
   

mise en place du code complet ci-dessous. J'ai mis ActiveSheet à un variable Sht et ajouté tour de ScreenUpdating pour améliorer l'efficacité. Comme il y a beaucoup de données, je m'assure de clarifier les variables à la fin.

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