VBA - optimisation suppression lignes

Bonjour,

J'aimerais votre avis sur l'optimisation du code suivant.

Je récupère un fichier dans lequel il y a plus de 200000 lignes. Parmi celles-ci, seules celles dont les colonnes A ou B contiennent "PC" m'intéressent. Je souhaite supprimer les autres pour alléger le fichier.
Le code suivant permet de supprimer les lignes inutiles mais prend un peu de temps (7-8 minutes lors d'un test).

Je me demande s'il est possible d'améliorer le code pour réduire son temps de traitement.

Option Explicit
Sub suppr()

Dim BoEcran, BoBarre, BoEvent As Boolean
Dim i, DerL As Long

BoEcran = Application.ScreenUpdating
BoBarre = Application.DisplayStatusBar
Application.Calculation = xlCalculationManual
BoEvent = Application.EnableEvents

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

DerL = Sheets("Feuil1").Columns(1).Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For i = DerL To 2 Step -1
    If InStr(1, Sheets("Feuil1").Cells(i, 1).Value, "PC", 1) = 0 And InStr(1, Sheets("Feuil1").Cells(i, 2).Value, "PC", 1) = 0 Then
        Sheets("Feuil1").Rows(i).EntireRow.Delete
    End If
Next i

Application.ScreenUpdating = BoEcran
Application.DisplayStatusBar = BoBarre
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = BoEvent

End Sub

Merci

Salut Oups,

ainsi, peut-être ?
Un double-clic sur la feuille démarre la macro.

Il faudra sans doute adapter la boucle FOR...NEXT qui démarre en [A1]...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab, rCells As Range
'
Application.ScreenUpdating = False
tTab = Range("A1:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
'
For x = 1 To UBound(tTab, 1)
    If InStr(tTab(x, 1), "PC") = 0 And InStr(tTab(x, 2), "PC") = 0 Then
        If rCells Is Nothing Then
            Set rCells = Rows(x)
        Else
            Set rCells = Union(rCells, Rows(x))
        End If
    End If
Next
rCells.Delete shift:=xlUp
'
Application.ScreenUpdating = True
'
End Sub

A+

Bonsoir,

Tu utilises excel365, as tu essayé avec Power Query ?

Cordialement.

Salut Oups,
Salut Zebulon,

après test sur fichier factice de 200.000 lignes sur 26 colonnes, je me suis aperçu de l'ineptie de mon premier essai.
Ceci fonctionne en quelques petites secondes.
Un double-clic sur la feuille démarre la macro.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab
'
Cancel = True
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'
tTab = Range("A1:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
For x = 2 To UBound(tTab, 1)
    If InStr(tTab(x, 1), "PC") = 0 And InStr(tTab(x, 2), "PC") = 0 Then tTab(x, 1) = ""
Next
Range("A1").Resize(UBound(tTab, 1), 2).Value = tTab
Range("A1").Resize(UBound(tTab, 1), Cells(1, Columns.Count).End(xlToLeft).Column).Sort _
    key1:=Range("A2"), order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
Rows(Range("A" & Rows.Count).End(xlUp).Row + 1 & ":" & UBound(tTab, 1)).Delete shift:=xlUp
'
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'
End Sub

A+

Bonjour,

@curulis57,
Un test sur un petit fichier ?
A te relire.
Cdlt.

Salut Jean-Eric,

sais pas trop comment prendre ta demande...
Allez, pour le fun, la macro commence par créer une BDD factice de 200000 lignes x 26 colonnes.

Un double-clic sur la feuille démarre la macro.

A+

Bonjour,

Curulis57 : merci beaucoup, ça marche très bien. Je testerai lundi en l'adaptant au fichier réel.

Zebulon2 : de tête je ne sais pas. Je ne connais pas PowerQuery et la solution de Curulis57 me convient bien.

Bonjour à tous,

Pas de problème, le tout est que la solution te convienne.

Bonne continuation.

Bonjour,

@Curulis57,
Sur le coup, et sans avoir vraiment regardé ta proposition (), j'ai pensé (à tort) que l'on pouvait avoir un souci de restitution du tableau dans la feuille de calcul avec un grand nombre de lignes à rapatrier. Après réflexion, je me suis rappelé que ce type de souci était propre à la restitution d'un array avec Application.Transpose (65536 lignes ; relatif à Excel 2003 et inchangé depuis ?).

Ta proposition est donc parfaite et te prie de m'excuser de mon intervention qui prêtait à équivoque..

Une alternative avec array et Application.Transpose.

Cdlt.

Public Sub CleanData()
Dim tbl, arr()
Dim n As Long, i As Long, k As Long, lRow As Long
Dim t As Single
    t = Timer
    Application.ScreenUpdating = False
    With ActiveSheet
        lRow = 1
        n = .Cells(Rows.Count, 1).End(xlUp).Row
        tbl = .Cells(1).Resize(n, 3).Value
        .Cells(1).CurrentRegion.ClearContents
        For i = LBound(tbl) To UBound(tbl)
            If InStr(1, tbl(i, 1), "PC", 1) > 0 Or InStr(1, tbl(i, 2), "PC", 1) > 0 Then
                ReDim Preserve arr(3, k + 1)
                arr(0, k) = tbl(i, 1)
                arr(1, k) = tbl(i, 2)
                arr(2, k) = tbl(i, 3)
                k = k + 1
            End If
            If k >= 65000 Then
                    .Cells(lRow, 1).Resize(k, 3).Value = Application.Transpose(arr)
                    lRow = k + 1
                    k = 0
                End If
        Next i
        .Cells(lRow, 1).Resize(k, 3).Value = Application.Transpose(arr)
        .UsedRange
    End With
    MsgBox VBA.Round(Timer - t, 2) & " secondes"
End Sub

Salut Jean-Eric,

après mon premier essai foireux, Google étant mon ami aussi, j'ai un peu trifouillé partout et découvert que ma première méthode (créer une Range des lignes à éliminer) se heurtait à une limite de +- 8000 zones.
En saucissonnant les 200.000 lignes en blocs de 15.000 lignes (même principe que tes blocs de 65.000 lignes), j'arrivais quand même à 3-4 minutes de traitement.
Puis, une phrase m'a mis sur la piste de ma 2e version forum.

En appliquant ton code aux 200.000 lignes x 26 colonnes, j'arrive sur ma machine à +- 23" de traitement contre +- 3" pour ma version.
Hasard, chance, j'ai réussi cela à l'insu de mon plein gré !

Pas de souci pour "l'impression", tu penses bien : c'est en confrontant nos connaissances que l'on progresse !

A+

Bonjour,

Pour le fun !

Option Explicit
'principe : http://boisgontierj.free.fr/
Public Sub CleanData()
Dim tbl, arr, lastRow As Long, n As Long, i As Long, j As Long, k As Long
Dim modCalc As XlCalculation
Dim t0 As Single, t2 As Single, t3 As Single
    t0 = Timer
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        tbl = .Cells(1).CurrentRegion.Value
        For i = 1 To UBound(tbl)
            If InStr(1, tbl(i, 1), "PC", 1) > 0 Or InStr(1, tbl(i, 2), "PC", 1) > 0 Then n = n + 1
        Next i
        ReDim arr(1 To n, 1 To UBound(tbl, 2))
        For i = 1 To UBound(tbl)
            If InStr(1, tbl(i, 1), "PC", 1) > 0 Or InStr(1, tbl(i, 2), "PC", 1) > 0 Then
                j = j + 1
                For k = 1 To UBound(tbl, 2)
                    arr(j, k) = tbl(i, k)
                Next k
            End If
        Next i
        t2 = Timer
        Debug.Print "Traitement : " & VBA.Round(t2 - t0, 2) & " secondes"
        With .Cells(1)
            .CurrentRegion.ClearContents
            .Resize(UBound(arr), UBound(arr, 2)) = arr
        End With
        .UsedRange
        .Application.Goto .Cells(1), True
    End With
    t3 = Timer
    Debug.Print "Restitution : " & VBA.Round(t3 - t2, 2) & " secondes"
    Debug.Print "Total : " & VBA.Round(t3 - t0, 2) & " secondes"
End Sub

Salut Jean-Eric,

évident comme méthode ! Pourquoi encore s'embêter avec SpecialCells(Blanks) à part la concision du code ?
Au test, 4"50 pour toi contre 3"15 : Sort apparaît toujours plus rapide !

A+