Lenteur macro

[KTM]

BONJOUR Le FORUM
jai une enorme base de données à exploiter
Le code ci dessous supprime toutes les lignes ne contenant pas le mot MUAC dans la colonne 20
Ce code fonctionne mais le soucis c'est que l'execution est hyper lente ( plus de quatre min)

Application.ScreenUpdating = False
Sheets("A").Select
Dim i As Long
For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If Not Cells(i, 20) Like "MUAC" Then Rows(i).Delete
Next
Application.ScreenUpdating = True

j'aimerais savoir si cette lenteur est au volume de données ou si c'est mon code qui n'est pas adéquat , dans ce cas pouvez vous m'en proposer ?

 

[BOISGONTIER]

Bonjour,

voir exemple en pj

Option Compare Text
Sub supLignesRapide2()
  Application.ScreenUpdating = False
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "muac" Then a(i, 1) = 0 Else a(i, 1) = "sup"
  Next i
  Columns("b:b").Insert Shift:=xlToRight
  [B2].Resize(UBound(a)) = a
  [A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  Range("B2:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Boisgontier

 

[Dranreb]

Bonjour.
Ceci aurait peut être aussi des chances d'être plus rapide :

Dim Wsh As Worksheet, TV(), L As Long, RngDel
Set Wsh = Worksheets("A")
TV = Intersect(Wsh.Columns(20), Wsh.UsedRange).Value
For L = 2 To UBound(TV, 1)
   If Not TV(L, 1) Like "*MUAC*" Then
      If RngDel Is Nothing Then
         Set RngDel = Wsh.Rows(L)
      Else
         Set RngDel = Union(RngDel, Wsh.Rows(L))
         End If
      End If
   Next L
If Not RngDel Is Nothing Then RngDel.Delete

 

[KTM]

Bonjour,

voir exemple en pj

Option Compare Text
Sub supLignesRapide2()
  Application.ScreenUpdating = False
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "muac" Then a(i, 1) = 0 Else a(i, 1) = "sup"
  Next i
  Columns("b:b").Insert Shift:=xlToRight
  [B2].Resize(UBound(a)) = a
  [A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  Range("B2:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Boisgontier

Testé et Vrai !! Super Super
Mais pouvez vous apporter quelques commentaires pour la Compréhension ? Merci

 

[KTM]

Bonjour.
Ceci aurait peut être aussi des chances d'être plus rapide :

Dim Wsh As Worksheet, TV(), L As Long, RngDel
Set Wsh = Worksheets("A")
TV = Intersect(Wsh.Columns(20), Wsh.UsedRange).Value
For L = 2 To UBound(TV, 1)
   If Not TV(L, 1) Like "*MUAC*" Then
      If RngDel Is Nothing Then
         Set RngDel = Wsh.Rows(L)
      Else
         Set RngDel = Union(RngDel, Wsh.Rows(L))
         End If
      End If
   Next L
If Not RngDel Is Nothing Then RngDel.Delete

Merci beaucoup !!!

 

[BOISGONTIER]

On regroupe les lignes à supprimer en fin de tableau à l'aide d'un tri puis on les supprime

-Mettre un STOP
-puis exécuter en pas à pas avec F8

Option Compare Text
Sub supLignesRapide2()
  Application.ScreenUpdating = False
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "muac" Then a(i, 1) = 0 Else a(i, 1) = "sup"
  Next i
  Columns("b:b").Insert Shift:=xlToRight
  [B2].Resize(UBound(a)) = a
  Stop
  [A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  Range("B2:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Boisgontier

 

[KTM]

Super Merci