XL 2013 Boucle qui tourne ds le vide.

[Wyrgle]

Bonjour à tous,

Voici un bout de code qui mouline dans le vide.
Je cherche à conserver seules les lignes en col 6 qui égalent l'année choisit ds un UserForm.
Je pars du haut (ligne 2) ou d'en bas (le rang de ma derniere ligne est 19038 environ...), je ne sors jamais ds la 2eme boucle.
(j'ai séparé les 2 boucles pour plus de clarté)

Last_Line = ActiveSheet.UsedRange.Rows.Count
For i = Last_Line To 2 Step -1
'---Prend l'année seule de la date :
    Cells(i, 6) = Year(Cells(i, 6))
Next i

For i = Last_Line To 2 Step -1
'---Si l'année est différente de Année choisie par le user, on efface la ligne :
    If Cells(i, 6).Value <> Annee_pour_traitement Then Rows(i).EntireRow.Delete
Next i

Ou est l'erreur ?
Merci pour votre aide !!

 

[eriiic]

Bonjour,

tu ne peux pas ne pas sortir de la 2nde boucle, il faut lui laisser le temps, c'est tout.
Avec un filtre auto où tu supprimes les lignes restées visibles ça irait beaucoup plus vite.
eric

 

[MMYSofts]

y'a aucun problème à part la lenteur de l'exécution qui serait égale au temps qu'il aurait fallu pour tirer la 1ere cellule jusqu'à 19038

 

[Dranreb]

Bonsoir.
À essayer :

Sub Test()
   Dim Année As Long
   Année = 2019
   LignesOùCondR1C1(Rows(2), "YEAR(RC6)<>" & Année).Delete
   End Sub
Function LignesOùCondR1C1(ByVal LigneDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Lignes entières partant de LigneDéb vérifiant une condition R1C1 CondR1C1.
   Dim Rng As Range
   Set Rng = PlageÀPartirDe(LigneDéb.EntireRow): If Rng Is Nothing Then Exit Function
   Set Rng = Rng.Columns(Rng.Columns.Count + 1)
   Application.ScreenUpdating = False
   On Error Resume Next
   Rng.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
   Set LignesOùCondR1C1 = Rng.SpecialCells(xlCellTypeFormulas, 1).EntireRow
   Rng.Delete xlShiftToLeft
   End Function
Function PlageÀPartirDe(ByVal CelDéb As Range) As Range
Rem. ——— Plage utilisée à partir de CelDéb.
   Dim NbrLig As Long, NBrCol As Long
   With CelDéb.Worksheet.UsedRange:
      NbrLig = .Row + .Rows.Count - CelDéb.Row
      NBrCol = .Column + .Columns.Count - CelDéb.Column
      If NbrLig <= 0 Or NBrCol <= 0 Then Exit Function
      End With
   Set PlageÀPartirDe = CelDéb.Resize(NbrLig, NBrCol)
   End Function