Macro pour supprimer lignes dont 3 colonnes sont égales à 0

A

AntoineLacroze

XLDnaute Nouveau
Bonjour à tous,

Fidèle lecteur et admirateur de ce forum, je me permets de faire appel à vous pour un sujet qui me pose quelques difficultés.

Dans le fichier ci-joint, j'aimerais supprimer via macro-commande toutes les ligne dont les colonnes B = C = D = 0.

Vous remerciant par avance et vous souhaitant un bonne journée

:)
 

Pièces jointes

  • TableALA.xls
    17 KB · Affichages: 87
Trier par date Trier par votes
Efgé

Efgé

XLDnaute Barbatruc
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Bonjour AntoineLacroze,
Une proposition:
Code: 
Sub Delete_lignes()
Dim derlig As Long
derlig = Range("A" & Application.Rows.Count).End(xlUp).Row + 1
For i = 2 To derlig
If Cells(i, 2).Value = "0" And Cells(i, 3).Value = "0" And Cells(i, 4).Value = "0" Then
    Cells(i, 1).EntireRow.Delete Shift:=xlUp
End If
Next i
End Sub
Cordialement
 

Pièces jointes

  • TableALA(2).xls
    24 KB · Affichages: 74
  • TableALA(2).xls
    24 KB · Affichages: 73
  • TableALA(2).xls
    24 KB · Affichages: 82
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Une modif pour ne pas oublier de lignes...
Code: 
Sub Delete_lignes()
Dim derlig As Long
derlig = Range("A" & Application.Rows.Count).End(xlUp).Row + 1
For i = derlig To 2 Step -1
If Cells(i, 2).Value = "0" And Cells(i, 3).Value = "0" And Cells(i, 4).Value = "0" Then
    Cells(i, 1).EntireRow.Delete Shift:=xlUp
End If
Next i
End Sub
Cordialement
 

Pièces jointes

  • TableALA(2).xls
    24 KB · Affichages: 73
  • TableALA(2).xls
    24 KB · Affichages: 79
  • TableALA(2).xls
    24 KB · Affichages: 79
Vote positif 0 Vote négatif
Hulk

Hulk

XLDnaute Barbatruc
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Hello,

Une autre version...
Code: 
Private Sub CommandButton1_Click()
    
    Dim x As Range

    Application.ScreenUpdating = False
    
    For Each x In Range("A1:A" & Range("A65536").End(xlUp).Row)
        If Range("B" & x.Row & ":D" & x.Row).Text = 0 Then x.Rows.EntireRow.Delete
    Next x

End Sub
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Bonsoir à tous

Une autre version (avec le filtre élaboré, ce qui évite la boucle)

Code: 
Sub a()
With Sheets("Table")
    With .[A1]
        .Offset(1, 5).FormulaR1C1 = "=COUNTIF(RC[-4]:RC[-2],0)=3"
        .Resize([A65536].End(xlUp).Row, 4).AdvancedFilter xlFilterInPlace, [F1:F2], False
    End With
    .[_FilterDataBase].SpecialCells(12).Offset(1).EntireRow.Delete
    .ShowAllData: .[F2].Clear
End With
End Sub
 
Vote positif 0 Vote négatif
A

AntoineLacroze

XLDnaute Nouveau
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Merci beaucoup à tous les trois. Je n'ai pas encore testé la solution de Staple1600 et pour l'instant celle qui a ma préférence (rapidité notamment compte-tenu de la taille de mes fichiers et du nombre de lignes à supprimer) est celle d'Efgé.

Merci encore à tous :)
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Bonsoir


Il y avait un bug dans le précédent code
Code: 
Sub a()
Dim lae As Range
Application.ScreenUpdating = False
With Sheets("Table")
    With .[A1]
        .Offset(1, 5).FormulaR1C1 = "=COUNTIF(RC[-4]:RC[-2],0)=3"
        .Resize([A65536].End(xlUp).Row, 4).AdvancedFilter xlFilterInPlace, [F1:F2], False
    End With
    Set lae = .[_FilterDataBase].Offset(1, 0)
    lae.Offset(1).Resize(lae.Rows.Count - 1).SpecialCells(12).Delete Shift:=xlUp
    .ShowAllData: .[F2].Clear
End With
Application.ScreenUpdating = True
End Sub
PS: lors de tests sur 1000 lignes
ma macro s'exécute en 0.43 secondes
celle d'Efgé en 0.93 secondes
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Bonsoir


Désolé Efgé non :D

Car j'avais ajouté Application.ScreenUpdating = False
dans ton code

Voici le code utilisé pour chronométrer nos codes

Code: 
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
Sub Delete_lignes()
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim derlig As Long
QueryPerformanceCounter Debut
Application.ScreenUpdating = False
derlig = Range("A" & Application.Rows.Count).End(xlUp).Row + 1
For i = derlig To 2 Step -1
If Cells(i, 2).Value = "0" And Cells(i, 3).Value = "0" And Cells(i, 4).Value = "0" Then
    Cells(i, 1).EntireRow.Delete Shift:=xlUp
End If
Next i
Application.ScreenUpdating = True
QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
MsgBox "Durée de la procédure = " & Format(((Fin - Debut) / Freq), "0.00") & " s"
End Sub
Code: 
Sub a()
Dim lae As Range
Dim Debut As Currency, Fin As Currency, Freq As Currency
Application.ScreenUpdating = False
QueryPerformanceCounter Debut
With Sheets("Table")
    With .[A1]
        .Offset(1, 5).FormulaR1C1 = "=COUNTIF(RC[-4]:RC[-2],0)=3"
        .Resize([A65536].End(xlUp).Row, 4).AdvancedFilter xlFilterInPlace, [F1:F2], False
    End With
    Set lae = .[_FilterDataBase].Offset(1, 0)
    lae.Offset(1).Resize(lae.Rows.Count - 1).SpecialCells(12).Delete Shift:=xlUp
    .ShowAllData: .[F2].Clear
End With
Application.ScreenUpdating = True
 QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
MsgBox "Durée de la procédure = " & Format(((Fin - Debut) / Freq), "0.00") & " s"
End Sub
PS: le code de chronométrage est de kiki29
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Bonsoir à tous,

Peut-être pour accélérer (un peu) le code d'Efgé :

Code: 
If Cells(i, 2) & Cells(i, 3) & Cells(i, 4) = "000" Then

A condition qu'une cellule ne puisse pas contenir une valeur texte "00" ou "000".

A+
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Bonjour à tous,
Il faudrait que nous partions tous sur le même fichier.
Je propose pour continuer cette lutte fraternelle de prendre comme base le fichier joint.
En prenant comme base le chrono de kiki29 et 1 000 lignes:
La formule avec boucle (la miene) prend 0.12 Seconde.
La formule de Staple1600 prend 0.04 Secondes
Avec la modif de job75 nous arrivons à 0.05 Secondes.
Je reconnais bien volontier la victoire de Staple1600. :D

Je remercie job75 pour son intervention (qui aurais pu me donner un avantage ...):D
Si d'autres "intervenants" veulent proposer des solutions (en prenant en compte les "règles") ....
Temps à battre 0.04 Seconde.
Corfialement
EDIT: oublier de joindre le fichier :eek:
 

Pièces jointes

  • TableALA(3).zip
    15.9 KB · Affichages: 35
Dernière édition:
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Re

Temps à battre 0.04 Seconde
Cliquez pour agrandir...
Record battu :D (merci ROGER2327)

sur mon PC: 0,02 s

PS: je ne suis pas très sur la fiabilité du chronomètre car parfois les temps affichés ont fluctuants ??

Code: 
Sub version_inspired_by_ROGER2327()
Dim i As Long, j As Long, l As Long
Dim oDat, oDbl
Dim Debut As Currency, Fin As Currency, Freq As Currency
Application.ScreenUpdating = False
QueryPerformanceCounter Debut
oDat = Sheets("Table").[A1].CurrentRegion.Value
Sheets("Table").[A2:E1004].ClearContents
l = 1
ReDim oDbl(1 To UBound(oDat, 2), 1 To l)
For i = 2 To UBound(oDat, 1)
If oDat(i, 2) + oDat(i, 3) + oDat(i, 4) > 0 Then
ReDim Preserve oDbl(1 To UBound(oDat, 2), 1 To l)
         For j = 1 To UBound(oDat, 2)
            oDbl(j, l) = oDat(i, j)
         Next j
         l = l + 1
      End If
   Next i
Sheets("Table").Range(Sheets("Table").Cells(2, 1), Sheets("Table").Cells(UBound(oDbl, 2), 5)).Value = Application.Transpose(oDbl)
QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
MsgBox "Durée de la procédure = " & Format(((Fin - Debut) / Freq), "0.00") & " s"
Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Re...
Staple1600 à dit:
Re


Record battu :D (merci ROGER2327)

sur mon PC: 0,02 s

(...)
Cliquez pour agrandir...
Merci pour la citation !
Attention toutefois avec

If oDat(i, 2) + oDat(i, 3) + oDat(i, 4) > 0 Then
​

Si par malheur il advenait que oDat(i, 2), oDat(i, 3) et oDat(i, 4) pussent prendre les valeurs 0, 1 et -1, la ligne i serait indûment perdue...

On peut (peut-être...) encore gratter quelques millièmes en modifiant ainsi :
Code: 
[COLOR="DarkSlateGray"][B]Option Explicit

Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean

Sub version_revue_par_ROGER2327()
Dim i As Long, j As Long, l As Long, uDt As Long
Dim oDat, oDbl
Dim Debut As Currency, Fin As Currency, Freq As Currency
   Application.ScreenUpdating = False
   QueryPerformanceCounter Debut
   With Sheets("Table")
      oDat = .[A1].CurrentRegion.Value
      .[A1].CurrentRegion.Offset(1, 0).ClearContents
      uDt = UBound(oDat, 2)
      l = 1
      ReDim oDbl(1 To uDt, 1 To l)
      For i = 2 To UBound(oDat, 1)
         If (oDat(i, 2) <> 0) + (oDat(i, 3) <> 0) + (oDat(i, 4) <> 0) Then
            ReDim Preserve oDbl(1 To uDt, 1 To l)
            For j = 1 To uDt
               oDbl(j, l) = oDat(i, j)
            Next j
            l = l + 1
         End If
      Next i
      .Range(.Cells(2, 1), .Cells(UBound(oDbl, 2), 5)).Value = Application.Transpose(oDbl)
   End With
   QueryPerformanceCounter Fin
   QueryPerformanceFrequency Freq
   MsgBox "Durée de la procédure = " & Format(((Fin - Debut) / Freq), "0.00") & " s"
   Application.ScreenUpdating = True
End Sub[/B][/COLOR]
A vérifier dans les mêmes conditions que les autres procédures...​
Cordialement,
ROGER2327
#2732
 
Dernière édition:
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Re

Merci ROGER2327 d'avoir corrigée ma bévue
(et merci pour la beauté et la fluidité des codes que tu distilles ici)

Avec ta version et sur mon PC le temps est le même : 0,02 s

(Je suis de moins en moins sur du temps renvoyé par ce chronomètre :confused: )

EDITION :pour varier les plaisirs , une version avec AutoFilter
Code: 
Sub b() [COLOR=Green]'Temps d'exécution: 0.14 s[/COLOR]
Dim Debut As Currency, Fin As Currency, Freq As Currency
Application.ScreenUpdating = False
QueryPerformanceCounter Debut
    With Range("A1")
        .AutoFilter 2, " 0": .AutoFilter 3, " 0": .AutoFilter 4, " 0"
        .CurrentRegion.Offset(1, 0).EntireRow.Delete
    End With
ActiveSheet.ShowAllData
Application.ScreenUpdating = True
QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
MsgBox "Durée de la procédure = " & Format(((Fin - Debut) / Freq), "0.00") & " s"
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
A

Amrane

XLDnaute Junior
Re : Macro pour supprimer lignes dont 3 colonnes sont égales à 0

Efgé à dit:
Bonjour AntoineLacroze,
Une proposition:
Code: 
Sub Delete_lignes()
Dim derlig As Long
derlig = Range("A" & Application.Rows.Count).End(xlUp).Row + 1
For i = 2 To derlig
If Cells(i, 2).Value = "0" And Cells(i, 3).Value = "0" And Cells(i, 4).Value = "0" Then
    Cells(i, 1).EntireRow.Delete Shift:=xlUp


End If
Next i
End Sub
Cordialement
Cliquez pour agrandir...


================

C'est Extra bon

Amrane

:)
 
Vote positif 0 Vote négatif

Discussions similaires

Usine à gaz
  • Résolu(e)
XL 2021 Supprimer les lignes qui contiennent des cellules vides dans les colonnes "A à M" à partir de la ligne 5
Réponses
6
Affichages
254
Usine à gaz
Usine à gaz
M
  • Résolu(e)
XL 2010 Supprimer lignes à 0 sur plusieurs colonnes
Réponses
12
Affichages
328
job75
job75
C
  • Question
Microsoft 365 Macro permettant de comparer deux colonnes
Réponses
12
Affichages
443
AtTheOne
AtTheOne
E
  • Question
Microsoft 365 Extraire automatiquement les lignes d'un tableau dont une des colonnes contient le mot "oui"
Réponses
4
Affichages
861
Eric32000
E
B
  • Question
XL 2016 Macro BVA pour créer une synthèse à partir de plusieurs onglets Excel
Réponses
6
Affichages
595
bnolwalid
B
Y
  • Question
XL 2019 Macro pour supprimer des lignes selon caractères
Réponses
2
Affichages
600
Yoshi0302
Y
J
  • Question
XL 2016 macro pour remplir un calendrier à partir d'une liste d'évènements
Réponses
3
Affichages
367
julien6337
J
D
  • Question
XL 2019 Concaténer plusieurs lignes à partir d'une référence en doublon
Réponses
5
Affichages
427
vgendron
vgendron
L
  • Question
Microsoft 365 Macro pour aide facturation
Réponses
3
Affichages
267
AtTheOne
AtTheOne
L
  • Question
XL 2016 Macro VBA, colonnes de 3 feuilles différentes assemblées sans doublon
2
Réponses
20
Affichages
1 K
Lou61
L

Membres actuellement en ligne

3 membres et 33 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 206
Messages
2 086 219
Membres
103 158
dernier inscrit
laufin