Microsoft 365 suppression de ligne si condition (vba)

Karim48

XLDnaute Nouveau
Bonjour,

Dans le fichier ci-joint, j'aimerais supprimer toutes les lignes ne contenant pas la valeur 3 en colonne Q. J'ai bien essayer cette formule mais elle ne fonctionne pas:

Sub EntireRow()
Dim I As Integer
For I = Range("Q" & Rows.Count).End(xlUp).Row To 1 Step -1
If Cells(I, 17) = "" Then Cells(I, 1).EntireRow.Delete

Next I
End Sub

Merci par avance pour l'aide que vous pourrez m'apporter.
 

Pièces jointes

  • Classeur1.xlsm
    496.7 KB · Affichages: 3

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Karim,

j'aimerais supprimer toutes les lignes ne contenant pas la valeur 3
Alors pourquoi testez vous si Q est vide ? Ou alors Q ne peut avoir que 3 ou vide ?
Testez :
VB:
If Cells(I, 17) <> 3 Then Cells(I, 1).EntireRow.Delete
et rajoutez un Application.ScreenUpdating = False pour figer l'écarn ça ira beaucoup plus vite

Code:
Sub EntireRow()
Application.ScreenUpdating = False
Dim I As Integer
     For I = Range("Q" & Rows.Count).End(xlUp).Row To 1 Step -1
             If Cells(I, 17) <> 3 Then Cells(I, 1).EntireRow.Delete
     Next I
End Sub

Si vous avez énormément de lignes il faut passer par un autre algo pour être plus rapide.
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re Karim, bonsoir Bruno,
@Karim, testez cette PJ avec la macro SuppLignes.
Sur mon vieux PC, XL2007, on passe de 3.35s avec votre macro à 0.13s. Avec :
VB:
Sub SuppLignes()
T0 = Timer  ' A supprimer, juste pour mesurer le temps
    Application.ScreenUpdating = False                  ' On fige l'écran
    DL = [Q65000].End(xlUp).Row                         ' Dernière ligne de Résultat
    Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove ' Insertion colonne en A
    f = "=SI(R2<>3;CAR(1);0)"                           ' Formule utilisée
    With Range("A2:A" & DL)                             ' Plage où coller la formule qui sera triée, dernière colonne qui peut toujours être utilisée XFD
        .FormulaLocal = f                               ' Coller formule
        .EntireRow.Sort .Cells, xlDescending            ' Tri pour regrouper et accélérer
        .SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete  ' Suppression des lignes concernées
        .Delete Shift:=xlToLeft                         ' Effacement colonne formules
    End With
    Columns.AutoFit                                     'Ajustement largeurs colonnes
    With ActiveSheet.UsedRange: End With                'Ajustement barres de défilement
MsgBox Timer - T0  ' A supprimer
End Sub
 

Pièces jointes

  • Classeur1 (1).xlsm
    973.6 KB · Affichages: 2

Dudu2

XLDnaute Barbatruc
Bonjour @Karim48, @sylvanu, @BrunoM45,

Perso, je préfèrerais mettre le code dans un module plutôt que dans la feuille.
Sinon, une autre possibilité...
VB:
Sub DeleteRows()
    Dim i As Long
    Dim RangeDelete As Range
  
    With ActiveSheet
        For i = .UsedRange.Row To .UsedRange.Row + .UsedRange.Rows.Count - 1
            If Cells(i, "Q") <> 3 Then
                If RangeDelete Is Nothing Then
                    Set RangeDelete = Rows(i)
                Else
                    Set RangeDelete = Union(RangeDelete, Rows(i))
                End If
            End If
        Next i
    End With
  
    If Not RangeDelete Is Nothing Then RangeDelete.Delete
End Sub
 

Pièces jointes

  • Classeur1.xlsm
    503.4 KB · Affichages: 2

Discussions similaires

Réponses
6
Affichages
202

Statistiques des forums

Discussions
311 725
Messages
2 081 947
Membres
101 849
dernier inscrit
florentMIG