XL 2016 Lenteur Macro

[Jiheme]

Bonjour à tous
Ce code tout bête efface une ligne en fonction des données des cellules de la colonne B. Le problème c'est la lenteur, pour 20 lignes il faut environ 15 secondes, le problème c'est que ce tableau fait entre 6500 et 7000 lignes.

Est que quelqu'un aurait une solution pour accélérer le processus

Sub netoyage()  'Jiheme

Application.ScreenUpdating = False    'Bloque l'affichage pendant l'exécution de la macro.
Sheets("FORMATIONS SENSIBILISATIONS").Select   'Sélection de la feuille.

Dim x As Integer     'Déclaration de la variable x en entier

For x = 2 To 6500 Step 1
 If Range("B" & x).Value = "Sensibilisation R-TOL" Then Rows(x).Delete
Next x

Application.ScreenUpdating = True 'Remet l'affichage en service.

End Sub

Merci d'avance
Jiheme

 

[patricktoulon]

re
bonjour jiHeme
fait un filtre et delete les specialcells (xlvisible) en un coup

 

[Jiheme]

Bonsoir Patrick
J'ai essayé, résultat plantage au bout d'une heure et demie.

Jiheme

 

[Staple1600]

Bonsoir le fil, jiheme, patricktoulon

jiheme
Une version (à peaufiner avec un tri)

Sub SuppressionLignes()
Dim DL&
Application.ScreenUpdating = False
DL = Cells(Rows.Count, 2).End(3).Row
With Cells(2, Columns.Count).Resize(DL)
  .Formula = "=REPT(123,$B2=""Sensibilisation R-TOL"")*1"
  .SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
  .Clear
End With
End Sub

 

[Jiheme]

Bonsoir Staple

Je teste et vous tiens au courant.
Merci
Jiheme

 

[Jiheme]

Bonsoir,
Nette amélioration : entre 18 et 19 minutes, pas de plantage. Je ne pense pas que l'on puisse faire mieux.

Merci Staple, Patrick
A+

 

[Staple1600]

Re

Sur mon classeur de test, cette version (avec tri)

Sub SuppressionLignes_Avec_Tri()
Dim t, P As Range
t = Timer
Set P = ActiveSheet.UsedRange
Application.ScreenUpdating = False
With P.Columns(P.Columns.Count + 1)
  .Formula = "=REPT(123,$B2=""Sensibilisation R-TOL"")*1"
  .Value = .Value
  Union(P, .Cells).Sort .Cells, xlAscending 'tri pour accélérer
  On Error Resume Next
  .SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
  .Value = ""
End With
Set P = ActiveSheet.UsedRange 'MAJ des barres de défilement
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

La suppression se fait en 0.25
J'ai testé sur 10 000 lignes.
Pour faire le même test, lancer cette macro sur une feuille vierge avant de lancer la macro de suppression

Sub PourTest()
Application.ScreenUpdating = False
[B2:B4].Value = Application.Transpose(Array(1, "A", "Sensibilisation R-TOL"))
Range("B2:B4").AutoFill Destination:=Range("B2:B9999"), Type:=xlFillCopy
End Sub

NB: Code basé sur un code de job75
(je parle du code de suppression des lignes)