XL 2016 Lenteur Macro

Jiheme

XLDnaute Accro
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


VB:
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
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil, jiheme, patricktoulon

jiheme
Une version (à peaufiner avec un tri)
VB:
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
 

Staple1600

XLDnaute Barbatruc
Re

Sur mon classeur de test, cette version (avec tri)
VB:
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
VB:
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)
 

Discussions similaires

Réponses
12
Affichages
638