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

Je suis en train d'essayer de trouver un moyen de filtrer les données et supprimer des lignes dans une feuille de calcul, en moins d'une minute

L'objectif:

• Trouver tous les enregistrements contenant un texte spécifique dans la colonne 1, et de supprimer la ligne entière
• Garder toutes les cellules de mise en forme (couleurs, la police des frontières, les largeurs de colonne) et les formules qu'ils sont

.

Données De Test:

:

.

Comment fonctionne le code:

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

2. Si le classeur n'est pas vide et la valeur texte supprimé existe dans la colonne 1

   • Des Copies de la plage utilisée de la colonne 1 pour un tableau
   • Itère sur chaque valeur dans le tableau en arrière

   • Lorsqu'il trouve une correspondance:

     • Ajoute l'adresse de la cellule à un tmp chaîne de caractères dans le format "A11,A275,A3900,..."
     • Si la variable tmp longueur est proche de 255 caractères
     • Supprime des lignes à l'aide de .Range("A11,A275,A3900,...").EntireRow.Delete Shift:=xlUp
     • Réinitialise tmp à vide et passer à la prochaine série de lignes
3. À la fin, il tourne toutes les fonctionnalités d'Excel de retour Sur

.

Le principal problème est l'opération de Suppression, et la durée totale doit être de moins d'une minute. Le code à base de solution est acceptable tant qu'il effectue en moins de 1 minute.

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

.

Ma principale fonction initiale:

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

---

Des fonctions d'assistance (activer les fonctionnalités d'Excel et de décollage):

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é 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

---

Renvoie l'index d'un match 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

.

Mise à jour:

Testé 6 solutions (3 tests de chaque): Excel Héros solution est la plus rapide jusqu'à présent (supprime les formules)

.

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

.

Test 1. Total de 100 000 enregistrements de, 10 000 à être supprimé:

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, de 100 000 à être supprimé:

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

.

Notes:

1. ExcelHero méthode: facile à mettre en œuvre, fiable, extrêmement rapide, mais supprime les formules
2. NewSheet méthode: facile à mettre en œuvre, fiable et respecte l'objectif
3. Chaînes de méthode: plus d'effort à mettre en œuvre, fiable, mais ne répond pas à l'exigence
4. Méthode de tableau: similaire à Cordes, mais ReDims un tableau (version plus rapide de l'Union)
5. QuickAndEasy: facile à mettre en œuvre (court, fiable et élégant), mais ne répond pas à l'exigence
6. Gamme de l'Union: la mise en œuvre de complexité similaire aux 2 et 3, mais trop lent

J'ai aussi fait le test des données plus réalistes, par l'introduction d'inhabituel valeurs:

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