web-dev-qa-db-fra.com

Performances VBA Excel - 1 million de lignes - Supprimez les lignes contenant une valeur en moins d'une minute

J'essaie de trouver un moyen de filtrer des données volumineuses et de supprimer des lignes dans une feuille de calcul en moins d'une minute

Le but:

  • Trouvez tous les enregistrements contenant du texte spécifique dans la colonne 1 et supprimez la ligne entière
  • Conservez tous les formats de cellules (couleurs, police, bordures, largeurs de colonne) et les formules tels quels.

.

Données de test:

Test data:

.

Comment fonctionne le code:

  1. Il commence par désactiver toutes les fonctionnalités d'Excel

  2. Si le classeur n'est pas vide et que la valeur de texte à supprimer existe dans la colonne 1

    • Copie la plage utilisée de la colonne 1 dans un tableau
    • Itère sur chaque valeur du tableau en arrière

    • Quand il trouve une correspondance:

      • Ajoute l'adresse de la cellule à une chaîne tmp au format "A11,A275,A3900,..."
      • Si la longueur de la variable tmp est proche de 255 caractères
      • Supprime les lignes en utilisant .Range("A11,A275,A3900,...").EntireRow.Delete Shift:=xlUp
      • Réinitialise tmp pour qu'il se vide et passe au jeu de lignes suivant
  3. A la fin, toutes les fonctionnalités d'Excel sont réactivées.

.

Le problème principal est l'opération de suppression}, et la durée totale doit être inférieure à une minute. Toute solution basée sur un code est acceptable tant qu'elle fonctionne moins d'une minute.

Cela réduit la portée à très peu de réponses acceptables. Les réponses déjà fournies sont également très courtes et faciles à mettre en œuvre. One effectue l'opération en environ 30 secondes. Il y a donc au moins une réponse qui offre une solution acceptable, et d'autres peuvent également la trouver utile.

.

Ma fonction initiale principale:

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

Fonctions d'assistance (activer et désactiver les fonctions Excel):

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

Trouve la dernière cellule avec des données (merci @ZygD - maintenant je l'ai testée dans plusieurs scénarios):

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

Retourne l'index d'une correspondance dans le tableau, ou 0 si aucune correspondance n'est trouvée:

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

.

Mettre à jour:

Testé 6 solutions (3 tests chacune): La solution Excel Hero est la plus rapide jusqu'à présent (supprime les formules)

.

Voici les résultats, du plus rapide au plus lent:

.

Test 1. Total de 100 000 enregistrements, dont 10 000 à supprimer:

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. Total de 1 million d'enregistrements, dont 100 000 à supprimer:

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

.

Remarques:

  1. Méthode ExcelHero: facile à mettre en œuvre, fiable, extrêmement rapide, mais supprime les formules
  2. Méthode NewSheet: facile à mettre en œuvre, fiable et répond aux objectifs
  3. Méthode de chaîne de caractères: plus d'effort à mettre en œuvre, fiable, mais ne répond pas aux exigences
  4. Méthode de tableau: similaire à Strings, mais ReDims un tableau (version plus rapide de Union)
  5. QuickAndEasy: facile à mettre en œuvre (court, fiable et élégant), mais ne répond pas aux exigences
  6. Range Union: complexité de mise en œuvre similaire à 2 et 3, mais trop lente

J'ai également rendu les données de test plus réalistes en introduisant des valeurs inhabituelles:

  • cellules vides, plages, lignes et colonnes
  • caractères spéciaux, comme = [`~! @ # $% ^ & * () _- + {} []\|;: '",. <>/?, combinaisons séparées et multiples
  • espaces, tabulations, formules vides, bordure, police et autres mises en forme de cellules
  • grands et petits nombres avec décimales (= 12.9999999999999 + 0.00000000000000001)
  • hyperliens, règles de mise en forme conditionnelle
  • formatage vide à l'intérieur et à l'extérieur des plages de données
  • tout ce qui pourrait causer des problèmes de données
excelperformancevbaexcel-vba
31
paul bica

Je fournis la première réponse comme référence

D'autres peuvent le trouver utile, s'il n'y a pas d'autres options disponibles

  • Le moyen le plus rapide d'obtenir le résultat est de ne pas utiliser l'opération Supprimer
  • Sur un million d'enregistrements, 100 000 lignes sont supprimées en une moyenne de 33 secondes

.

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

.

Au plus haut niveau:

  • Il crée une nouvelle feuille de travail et conserve une référence à la feuille initiale
  • Filtres automatiques de la colonne 1 sur le texte recherché: .AutoFilter Field:=1, Criteria1:="<>Test String"
  • Copie toutes les données (visibles) de la feuille initiale
  • Colle les largeurs de colonne, les formats et les données dans la nouvelle feuille
  • Supprime la feuille initiale
  • Renomme la nouvelle feuille en l'ancien nom

Il utilise les mêmes fonctions d'assistance affichées dans la question

Le 99% de la durée est utilisée par le filtre automatique

.

Il y a quelques limitations que j'ai trouvées jusqu'à présent, la première peut être adressée:

  1. S'il y a des lignes cachées sur la feuille initiale, elle les masque.

    • Une fonction séparée est nécessaire pour les cacher
    • En fonction de la mise en œuvre, cela pourrait augmenter considérablement la durée

  2. VBA liés:

    • Cela change le nom de code de la feuille; d'autres VBA faisant référence à Sheet1 seront cassés (le cas échéant)
    • Il supprime tout le code VBA associé à la feuille initiale (le cas échéant).

.

Quelques notes sur l’utilisation de gros fichiers comme ceci:

  • Le format binaire (.xlsb) réduit considérablement la taille du fichier (de 137 Mo à 43 Mo)

  • Les règles de mise en forme conditionnelle non gérées peuvent entraîner des problèmes de performances exponentielles

    • Même chose pour les commentaires et la validation des données

  • Lire un fichier ou des données sur le réseau est beaucoup plus lent que de travailler avec un fichier local

14
paul bica

Un gain de vitesse important peut être obtenu si les données source ne contiennent pas de formules ou si le scénario permet (ou souhaite) que les formules soient converties en valeurs absolues lors des suppressions de lignes conditionnelles.

Avec ce qui précède comme avertissement, ma solution utilise le filtre avancé de l’objet plage. Il 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
9
Excel Hero

Sur mon Dell Inspiron 1564 âgé (Win 7 Office 2007), ceci:

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 courir. Je suppose que la colonneAA AAest disponible.

EDIT # 1:

Veuillez noter que ce code ne pas définit Calcul sur Manuel. Les performances s'amélioreront si le mode de calcul est défini sur Manuel après la colonne "aide" est autorisée à calculer.

5
Gary's Student

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 que les lignes se retrouvent dans l'ordre d'origine. Toutefois, si vous ne craignez pas que les lignes soient dans un ordre différent, une colonne d'index n'est pas nécessaire et la ligne supplémentaire de le code peut être supprimé.

Mon approche: Mon approche consistait simplement à sélectionner toutes les lignes de la plage sélectionnée (colonne), à ​​les trier par ordre croissant en utilisant Range.Sort, puis à collecter le premier et le dernier index de "Test String" dans la plage sélectionnée (colonne). Je crée ensuite une plage à partir du premier et du dernier index et utilise Range.EntrieRow.Delete pour supprimer toutes les lignes contenant "Test String".

Avantages:  
- Il flambe vite. 
- Il ne supprime pas le formatage, les formules, les graphiques, les images ou quoi que ce soit d'autre que la méthode qui copie sur une nouvelle feuille. 

Les inconvénients:  
- Une taille de code décente à mettre en œuvre, mais tout est simple. 

Sous plage de test: 

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 des lignes Sous: 

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!

Temps à 100K entrées (10k à supprimer, FastWB True):  
1. 0,2 seconde. 
2. 0,2 seconde. 
3. 0,21 seconde. 
Moy. 0,2 seconde. 

Fois à 1 million d'entrées (100k à supprimer, FastWB True):  
1. 2,3 secondes. 
2. 2,32 secondes. 
3. 2,3 secondes. 
Moy. 2,31 secondes. 

En cours d'exécution sur: Windows 10, iMac i3 11,2 (à partir de 2010)

MODIFIER 
Ce code a été conçu à l'origine pour filtrer les valeurs numériques en dehors d'une plage numérique et a été adapté pour filtrer "Test String" afin qu'une partie du code soit redondante.

1
user2693587

Votre utilisation des tableaux pour calculer la plage utilisée et le nombre de lignes peut affecter les performances. Voici une autre approche qui, lors des tests, s’avère efficace sur plusieurs lignes de données, entre 25 et 30 secondes. Il n'utilise pas de filtres, donc supprime les lignes même si elles sont masquées. La suppression d'une ligne entière n'aura pas d'effet sur le formatage ni sur la largeur des colonnes des autres lignes. 

  1. Premièrement, vérifiez si ActiveSheet a "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 parcourez les lignes de données:

    While r <= EndRow

  4. Pour vérifier si la cellule de la colonne 1 est égale à "Chaîne de test":

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

  5. Pour supprimer la ligne: 

    Rows(r).Delete Shift:=xlUp

Rassembler tout le code complet ci-dessous. J'ai défini ActiveSheet sur une variable Sht et ajouté l'activation de ScreenUpdating pour améliorer l'efficacité. Puisqu'il y a beaucoup de données, je m'assure de supprimer 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
0
Andrew Toomey