Supréssion de ligne trés lente

Bonjours

Je reviens vers vous et vos grandes connaissances pour m'aider.

J'ai créé une macro qui me permet de copier des plages de cellules d'un onglet à un autre avec liaison.

Une fois la copie de mes lignes terminées, je supprime les lignes qui contiennent 0 dans ma colonne D.

A mon grand plaisir tout marche comme je veux, mais par contre la suppression des lignes est super lente (1m30 a peut prés pour 2000 lignes) .

Est-il possible de réduire ce temps avec une autre manière de faire ou suis-je condamné à attendre ?

Pour la suppression j'utilise ceci :

Dim i As Long
    For i = Range("D5000").End(xlUp).Row To 1 Step -1
        If Cells(i, 4).Value <= 0 Then
            Cells(i, 4).EntireRow.Delete
        End If
    Next

Voici ma macro complète (elle va vous paraitre surement très archaïque ) :

Sub tableau()

With Worksheets("Suivi FX 2018")
End With

'semaine 40

'copie plage 1
Worksheets("Suivi FX 2018").Range("A4:B200,QK4:QT200").Copy
Worksheets("test").Activate
Range("B2").Select
ActiveSheet.Paste Link:=True

'Copie plage 2
Worksheets("Suivi HG 2018").Range("A4:B300,QK4:QT300").Copy
Worksheets("test").Activate
Sheets("test").Cells(Rows.Count, 2).End(xlUp)(2).Select
ActiveSheet.Paste Link:=True

''Copie de cellule pour indiqué la numéros de semaine sur chaque ligne

Worksheets("Suivi FX 2018").Range("QL3").Copy
Worksheets("test").Activate
Range(Cells(2, 1), Cells(Rows.Count, 2).End(3)(1, 0)).Select
ActiveSheet.Paste Link:=True

'semaine 41

Worksheets("Suivi FX 2018").Range("A4:B200,QU4:RD200").Copy
Worksheets("test").Activate
Sheets("test").Cells(Rows.Count, 2).End(xlUp)(2).Select
ActiveSheet.Paste Link:=True

Worksheets("Suivi HG 2018").Range("A4:B300,QU4:RD300").Copy
Worksheets("test").Activate
Sheets("test").Cells(Rows.Count, 2).End(xlUp)(2).Select
ActiveSheet.Paste Link:=True

Worksheets("Suivi FX 2018").Range("QV3").Copy
Worksheets("test").Activate
derlig = Cells(Rows.Count, 2).End(xlUp).Select
Sheets("test").Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
Dim a As Integer, b As Integer

  a = Range("A" & Rows.Count).End(xlUp).Row
  b = Range("D" & Rows.Count).End(xlUp).Row

  For a = 2 To b
   If Cells(a, 1) = "" Then Cells(a, 1) = Cells(a - 1, 1)
  Next a

'Suppression des lignes

Dim i As Long
    For i = Range("D5000").End(xlUp).Row To 1 Step -1
        If Cells(i, 4).Value <= 0 Then
            Cells(i, 4).EntireRow.Delete
        End If
    Next

Je sais qu'il peut être utile de fournir une Excel pour la compréhension mais j'ai peur que se sois compliqué.

Merci d'avance

Bonjour,

Une autre option est de faire un tri sur les 0 pour les placer en fin de tableau, et de supprimer toutes ces lignes d'un coup.

Concernant ta macro complète, tu gagnerais à supprimer tous les "Select" et "Activate" (qui sont inutiles et ralentissent le code). A la place, il suffit de bien préciser les objets sur lesquels tu travailles, par exemple :

Worksheets("Feuil1").Activate
Range("A1").Select
Selection.Copy
Worksheets("test").Activate
Range("A2").Select
ActiveSheet.Paste Link:=True

Peut s'écrire :

Sheets("Feuil1").Range("A1").Copy 
Sheets("test").Range("A2").Paste Link:=True

Bonjour,

Teste en mettant

Application.ScreenUpdating = False

avant la boucle For de la partie de suppression de ligne

Salut M12,

J'ajouterai également,

--> En début de macro :

Application.Calculation = xlCalculationManual

--> A rétablir en fin de macro :

Application.Calculation = xlCalculationAutomatic

Qui sert à éviter le recalcul auto de toutes les formules Excel à chaque modification.

Merci Pedro22 et M12 pour vos réponses ultra rapide!!!!!!

Ton astuce avec "select et activate" réduit quand même bien mon parpaing de code

Application.ScreenUpdating = False

Réduisé déjà beaucoup le temps de traitement.

Mais avec sa en plus sa me prend 3seconde

Application.Calculation = xlCalculationManual