XL 2013 VBA amélioration macro suppression lignes

[n_xeon]

Bonjour à tous

Je dois supprimer dans un fichier +- 20000 lignes sur un total de 30000.
J'ai une macro qui fonctionne bien mais qui est très lente...

Application.ScreenUpdating = False

last_row = Range("B1").End(xlDown).Row
c_year = Year(Date)

For a = 2 To last_row

If Cells(a, 1).Value < c_year Or Cells(a, 1).Value = "" Then
Rows(a).Select
Selection.Delete Shift:=xlUp

a = a - 1
last_row = Range("B1").End(xlDown).Row

End If

Next a

Une idée de comment je pourrais améliorer mon temps d'exécution ?


Merci d'avance pour votre aide !!!!

 

[phlaurent55]

Re : VBA amélioration macro suppression lignes

Bonjour n-xeon, et bienvenue sur le forum

Application.ScreenUpdating = False

last_row = Range("B1").End(xlDown).Row
c_year = Year(Date)

For a = last_row To 2 Step-1
If Cells(a, 1).Value < c_year Or Cells(a, 1).Value = "" Then Rows(a).Delete
Next a
Application.ScreenUpdating = True

à+
Philippe

 

[MJ13]

Re : VBA amélioration macro suppression lignes

Bonjour n_xeon, Philippe

Le plus simple en général, ce serait de filtrer tes données et de copier ou de supprimer les lignes sélectionnées, selon le cas.

 

[DoubleZero]

Re : VBA amélioration macro suppression lignes

Bonjour, n_xeon, Philippe , Michel , le Forum,

Une autre façon d'agir :

Option Explicit
Sub Années_x_supprimer()
    Application.ScreenUpdating = False
    Range("b1").AutoFilter
    ActiveSheet.Range("b:b").AutoFilter Field:=1, Criteria1:="<" & CDate("01/01/" & Year(Now)), Operator:=xlAnd
    On Error GoTo fin
    Range("b2:b" & Rows.Count).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).EntireRow.Delete
    Range("b1").AutoFilter
    Exit Sub
    Application.ScreenUpdating = True
fin:
    MsgBox "Aucune date ancienne."
    Range("b1").AutoFilter
End Sub

A bientôt

 

[Marc L]

Une autre voie …

Bonjour,

si besoin dans la démonstration suivante remplacer Feuil1 par le CodeName de la feuille
ou une autre référence de la feuille de calculs comme ActiveSheet ou encore Worksheets :

​

Sub Demo()
         Application.ScreenUpdating = False
    With Feuil1.UsedRange.Resize(, Feuil1.UsedRange.Columns.Count + 1).Columns
        .Item(.Count).Rows("2:" & .Rows.Count).Formula = "=N(YEAR(A2)<" & Year(Date) & ")"
        .Sort .Cells(.Count), xlAscending, Header:=xlYes
        V = Application.Match(1, .Item(.Count), 0)
        .Item(.Count).Clear
        If IsNumeric(V) Then .Parent.Rows(V & ":" & .Rows.Count).Delete
    End With
         Application.ScreenUpdating = True
End Sub

_______________________________________________________________________________​

Merci de cliquer sur J'aime ce post en bas à gauche de chaque message ayant aidé …
​

_______________________________________________________________________________
​

Je suis Paris, Charlie, Bruxelles, …
​

 

[Paf]

Re : VBA amélioration macro suppression lignes

Bonjour à tous,

Pas sûr que ce soit plus rapide (11 secondes pour 10000 lignes sur 74 colonnes) mais à voir...
un essai macro tableau : on inscrit dans un tableau les lignes à conserver, puis on colle le tableau dans une nouvelle feuille ou dans la feuille principale (avec 1ligne à rajouter et 1 ligne à modifier)

Sub SupLig()
 Dim Tablo, TabFin(), i As Long, j As Integer, x As Long
 'deb = Timer
 Tablo = Worksheets("Feuil1").UsedRange
 For i = LBound(Tablo, 1) + 1 To UBound(Tablo, 1) ' +1 si ligne de titre
    If Year(Tablo(i, 1)) >= Year(Date) Then
        x = x + 1
        ReDim Preserve TabFin(1 To UBound(Tablo, 2), 1 To x)
        For j = LBound(Tablo, 2) To UBound(Tablo, 2)
            TabFin(j, x) = Tablo(i, j)
        Next
    End If
 Next

 Worksheets("Feuil2").Range("A2").Resize(UBound(TabFin, 2), UBound(TabFin, 1)) = Application.Transpose(TabFin)
 'MsgBox Timer - deb
End Sub

Noms de feuille à adapter

A+

 

[BOISGONTIER]

Re : VBA amélioration macro suppression lignes

Bonjour,

Suppression rapide

-On regroupe les lignes à supprimer en fin de tableau.
-La suppression des lignes ainsi regroupées en fin de tableau est très rapide.
-L'ordre initial des lignes n'est pas modifié.

-on repère les lignes à supprimer avec la valeur Sup
-on tri les lignes . Les lignes contenant Sup se retrouvent à la fin
-on supprime les lignes contenant Sup

http://boisgontierjacques.free.fr/fichiers/Cellules/SupLignesRapide.xls (0,2sec pour 20.000 lignes)

Suppression de lignes

jb

 

[n_xeon]

Re : VBA amélioration macro suppression lignes

Hello

Merci pour tous vos conseils, je m'en vais essayer tout ça !

A plus

 

[Marc L]

Re : VBA amélioration macro suppression lignes

-On regroupe les lignes à supprimer en fin de tableau.
-La suppression des lignes ainsi regroupées en fin de tableau est très rapide.
-L'ordre initial des lignes n'est pas modifié.

C'est exactement ce que j'ai proposé ! Non ?

​

 

[MJ13]

Re : VBA amélioration macro suppression lignes

Bonjour à tous

Voici un exemple avec filtre qui doit être facilement adaptable .

 

[Efgé]

Re : VBA amélioration macro suppression lignes

Bonjour à toutes et à tous,
J'y vais d'une enième version, un tableau comme Paf mais dans la même game de temps que le filtre
(Testé sur 20 000 lignes et 74 colonnes)
@Paf : C'est le Redim Preserve qui prend du temps et oblige à un transpose.

Sub test_FG()
Dim i&, j&, Rng As Range
Dim TData As Variant, T!
T = Timer


With Sheets("Feuil1")
    Set Rng = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(3)(1, 74))
End With


TData = Rng


For i = LBound(TData, 1) To UBound(TData, 1)
    If Year(TData(i, 1)) = Year(Date) Then
        X = X + 1
        For j = LBound(TData, 2) To UBound(TData, 2)
            TData(X, j) = TData(i, j)
        Next j
    End If
Next i



With Rng
    .ClearContents
    .Resize(X, UBound(TData, 2)).FormulaLocal = TData
End With

MsgBox Timer - T
End Sub

Cordialement