XL 2016 Supprimer ligne si chaque valeur dans les colonnes =0

A

AGDALT

XLDnaute Nouveau
Bonjour,

Je souhaite dans mon fichier supprimer les lignes où j'ai la valeur 0 dans chacune des 12 colonnes (1 colonne= 1mois).
Il se peut qu'un mois ait pour valeur 10 et un autre mois pour valeur -10, dans ce cas, je souhaite que la ligne reste et ne soit pas supprimée. Il ne faut donc pas faire de somme des 12 mois.
De plus, les 12 mois sont entre la colonne C et N mais si ces cellules font chacune zero, je voudrais supprimer la ligne entière (de colonne A à Z).

J'ai réussi à faire une macro qui fait le job mais l'éxecution est vraiment trop longue (10min). Il y a environ 6000 lignes et il en reste 1800 à la fin.

Auriez-vous une astuce pour raccourcir le temps d'éxecution?

Voila ce que j'ai écrit :

Sub Useless_Lines()

Application.ScreenUpdating = False
Dim iCalcul As Integer
iCalcul = Application.Calculation
Application.Calculation = False


'DELETE LINES WITH ZERO
Sheets("Forecast BI").Activate
Dim NbLine As Integer
Dim i As Integer
NbLine = Range("T" & Rows.Count).End(xlUp).Row

For i = NbLine To 1 Step -1
If Cells(i, 3) = 0 And Cells(i, 4) = 0 And Cells(i, 5) = 0 And Cells(i, 6) = 0 And Cells(i, 7) = 0 And Cells(i, 8) = 0 And Cells(i, 9) = 0 And Cells(i, 10) = 0 And Cells(i, 11) = 0 And Cells(i, 12) = 0 And Cells(i, 13) = 0 And Cells(i, 14) = 0 Then Rows(i).Delete
Next i

Application.Calculation = iCalcul
Application.ScreenUpdating = True



Merci d'avance,
 
Dernière édition:
Solution
Efgé
Bonjour à tous
Une proposition par tableau, qui vérifie les valeurs et non leur somme:
VB: 
Sub test()
Dim Plg As Range
Dim i&, LstRow&, J&, Col&, Col2&
Dim TMp As Variant
Dim Flg As Boolean

With Sheets("Forecast BI")
    LstRow = .Cells(.Rows.Count, 1).End(3).Row
    Set Plg = .Range("A2:T" & LstRow)
End With

TMp = Plg

For i = LBound(TMp, 1) To UBound(TMp, 1)
    Flg = False
    For Col = 3 To 13
        If TMp(i, Col) <> 0 Then Flg = True
    Next Col
    If Flg Then
    J = J + 1
        For Col2 = LBound(TMp, 2) To UBound(TMp, 2)
            TMp(J, Col2) = TMp(i, Col2)
        Next Col2
    End If
Next i

Application.ScreenUpdating = False
    Plg.ClearContents
    Plg.Resize(J, UBound(TMp, 2)) = TMp
Application.ScreenUpdating =...
Trier par date Trier par votes
A

AGDALT

XLDnaute Nouveau
Merci Sylvanu.
J'ai le message d'erreur "Sub ou fonction non défini" sur le Sum. Comment résoudre ça?

De plus, si une colonne = 10 et une autre =-10, la somme vaut zero mais je ne veux pas supprimer la ligne. Donc je pense que la solution proposée ne fonctionne pas. Confirmez-vous?
 
Vote positif 0 Vote négatif
D

danielco

XLDnaute Accro
Bonjour,

Essaie :

VB: 
Sub Useless_Lines()
  Dim Tabl1, Tabl2(), Ctr As Long, J As Long, K As Long
  Application.ScreenUpdating = False
  Dim iCalcul As Integer
  iCalcul = Application.Calculation
  Application.Calculation = False
  Sheets("Forecast BI").Activate
  Tabl1 = Range("C1", Cells(Rows.Count, 3).End(xlUp)).Resize(, 12)
 
  Dim NbLine As Integer
  Dim i As Integer
  NbLine = Range("T" & Rows.Count).End(xlUp).Row
  ReDim Tabl2(1 To NbLine, 1 To 12)
  For i = 1 To NbLine
    Ctr = 0
    For J = 1 To 12
      If Tabl1(i, J) <> 0 Then Ctr = Ctr + 1
    Next J
    If Ctr <> 0 Then
      K = K + 1
      For J = 1 To 12
        Tabl2(K, J) = Tabl1(i, J)
      Next J
    End If
  Next i
  Range("C1").Resize(NbLine, 12) = Tabl2
  Application.Calculation = iCalcul
  Application.ScreenUpdating = True
End Sub

Daniel
 
Vote positif 0 Vote négatif
A

AGDALT

XLDnaute Nouveau
Bonjour Daniel,
Merci beaucoup, le principe est très bon et rapide :). Cependant, je dois adapter le code car les 12 mois sont à la base entre la colonne C et N mais si ces cellules font chacune zero, je voudrais supprimer la ligne entière (de colonne A à Z) or pour le moment, ça ne supprime que les lignes entre C et N.

Pourrais-tu m'aider à adapter le code?

J'essaie de comprendre ce quoi mais j'ai des questions :
- A quoi correspond Tab11?
- A quoi correspond Tab12?

Merci d'avance
 
Vote positif 0 Vote négatif
Jacky67

Jacky67

XLDnaute Barbatruc
AGDALT à dit:
Bonjour,

Je souhaite dans mon fichier supprimer les lignes où j'ai la valeur 0 dans chacune des 12 colonnes (1 colonne= 1mois).
J'ai réussi à faire une macro qui fait le job mais l'éxecution est vraiment trop longue (10min). Il y a environ 6000 lignes et il en reste 1800 à la fin.

Auriez-vous une astuce pour raccourcir le temps d'éxecution?


Merci d'avance,
Cliquez pour agrandir...
Bonjour à tous

Une proposition avec exécution instantanée à tester avec un filtre
**Nécessite une ligne de titre

VB: 
Sub Useless_Lines()
    Dim NbLine&, Plage
    Application.ScreenUpdating = False
    Sheets("Forecast BI").Activate
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Columns(1).Insert
    NbLine = Range("U" & Rows.Count).End(xlUp).Row
    Set Plage = Range("a1:U" & NbLine)
    Range("a2:a" & NbLine).Formula = "=sum(d2:o2)"
    Plage.AutoFilter Field:=1, Criteria1:="0"
    On Error Resume Next    ' si aucun item à supprimer
    Plage.Offset(1).Resize(Plage.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Plage.AutoFilter
    Columns(1).Delete
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
A

AGDALT

XLDnaute Nouveau
Jacky67 à dit:
Bonjour à tous

Une proposition avec exécution instantanée à tester avec un filtre
**Nécessite une ligne de titre

VB: 
Sub Useless_Lines()
    Dim NbLine&, Plage
    Application.ScreenUpdating = False
    Sheets("Forecast BI").Activate
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Columns(1).Insert
    NbLine = Range("U" & Rows.Count).End(xlUp).Row
    Set Plage = Range("a1:U" & NbLine)
    Range("a2:a" & NbLine).Formula = "=sum(d2:o2)"
    Plage.AutoFilter Field:=1, Criteria1:="0"
    On Error Resume Next    ' si aucun item à supprimer
    Plage.Offset(1).Resize(Plage.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Plage.AutoFilter
    Columns(1).Delete
End Sub
Cliquez pour agrandir...
Bonjour Jacky et merci.
J'ai l'impression que le code fait la somme des mois et si la somme vaut zero alors la ligne est supprimée.
Or si une colonne = 10 et une autre =-10, la somme vaut zero mais je ne veux pas supprimer la ligne.
Est-ce le cas?

Merci
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Bonjour à tous
Une proposition par tableau, qui vérifie les valeurs et non leur somme:
VB: 
Sub test()
Dim Plg As Range
Dim i&, LstRow&, J&, Col&, Col2&
Dim TMp As Variant
Dim Flg As Boolean

With Sheets("Forecast BI")
    LstRow = .Cells(.Rows.Count, 1).End(3).Row
    Set Plg = .Range("A2:T" & LstRow)
End With

TMp = Plg

For i = LBound(TMp, 1) To UBound(TMp, 1)
    Flg = False
    For Col = 3 To 13
        If TMp(i, Col) <> 0 Then Flg = True
    Next Col
    If Flg Then
    J = J + 1
        For Col2 = LBound(TMp, 2) To UBound(TMp, 2)
            TMp(J, Col2) = TMp(i, Col2)
        Next Col2
    End If
Next i

Application.ScreenUpdating = False
    Plg.ClearContents
    Plg.Resize(J, UBound(TMp, 2)) = TMp
Application.ScreenUpdating = True
End Sub
Cordialement
 
Vote positif 0 Vote négatif
Solution
D

danielco

XLDnaute Accro
Pas testé. Sauvegarde bien le classeur avant d'esssayer :

VB: 
Sub Useless_Lines()
  Dim Tabl1, Tabl2(), Ctr As Long, J As Long, K As Long
  Application.ScreenUpdating = False
  Dim iCalcul As Integer
  iCalcul = Application.Calculation
  Application.Calculation = False
  Sheets("Forecast BI").Activate
  Tabl1 = Range("A1", Cells(Rows.Count, 3).End(xlUp)).Resize(, 26)
 
  Dim NbLine As Integer
  Dim i As Integer
  NbLine = Range("T" & Rows.Count).End(xlUp).Row
  ReDim Tabl2(1 To NbLine, 1 To 26)
  For i = 1 To NbLine
    Ctr = 0
    For J = 3 To 14
      If Tabl1(i, J) <> 0 Then Ctr = Ctr + 1
    Next J
    If Ctr <> 0 Then
      K = K + 1
      For J = 3 To 14
        Tabl2(K, J) = Tabl1(i, J)
      Next J
    End If
  Next i
  Range("A1").Resize(NbLine, 26) = Tabl2
  Application.Calculation = iCalcul
  Application.ScreenUpdating = True
End Sub

Daniel
 
Vote positif 0 Vote négatif
A

AGDALT

XLDnaute Nouveau
Efgé à dit:
Bonjour à tous
Une proposition par tableau, qui vérifie les valeurs et non leur somme:
VB: 
Sub test()
Dim Plg As Range
Dim i&, LstRow&, J&, Col&, Col2&
Dim TMp As Variant
Dim Flg As Boolean

With Sheets("Forecast BI")
    LstRow = .Cells(.Rows.Count, 1).End(3).Row
    Set Plg = .Range("A2:T" & LstRow)
End With

TMp = Plg

For i = LBound(TMp, 1) To UBound(TMp, 1)
    Flg = False
    For Col = 3 To 13
        If TMp(i, Col) <> 0 Then Flg = True
    Next Col
    If Flg Then
    J = J + 1
        For Col2 = LBound(TMp, 2) To UBound(TMp, 2)
            TMp(J, Col2) = TMp(i, Col2)
        Next Col2
    End If
Next i

Application.ScreenUpdating = False
    Plg.ClearContents
    Plg.Resize(J, UBound(TMp, 2)) = TMp
Application.ScreenUpdating = True
End Sub
Cordialement
Cliquez pour agrandir...
Merci beaucoup Efgé, ce code fonctionne :D
 
Vote positif 0 Vote négatif
Jacky67

Jacky67

XLDnaute Barbatruc
AGDALT à dit:
Bonjour Jacky et merci.
J'ai l'impression que le code fait la somme des mois et si la somme vaut zero alors la ligne est supprimée.
Or si une colonne = 10 et une autre =-10, la somme vaut zero mais je ne veux pas supprimer la ligne.
Est-ce le cas?

Merci
Cliquez pour agrandir...
Oui c'est bien le cas
Remplacer la ligne
Range("a2:a" & NbLine).Formula = "=sum(d2 : o2)"
Par
VB: 
 Range("a2:a" & NbLine).Formula = "=CountA(d2:o2)"

"

Ou mettre le classeur en ligne
 

Pièces jointes

  • Agald V1.xlsm
    127.7 KB · Affichages: 13
Vote positif 0 Vote négatif
A

AGDALT

XLDnaute Nouveau
danielco à dit:
Pas testé. Sauvegarde bien le classeur avant d'esssayer :

VB: 
Sub Useless_Lines()
  Dim Tabl1, Tabl2(), Ctr As Long, J As Long, K As Long
  Application.ScreenUpdating = False
  Dim iCalcul As Integer
  iCalcul = Application.Calculation
  Application.Calculation = False
  Sheets("Forecast BI").Activate
  Tabl1 = Range("A1", Cells(Rows.Count, 3).End(xlUp)).Resize(, 26)

  Dim NbLine As Integer
  Dim i As Integer
  NbLine = Range("T" & Rows.Count).End(xlUp).Row
  ReDim Tabl2(1 To NbLine, 1 To 26)
  For i = 1 To NbLine
    Ctr = 0
    For J = 3 To 14
      If Tabl1(i, J) <> 0 Then Ctr = Ctr + 1
    Next J
    If Ctr <> 0 Then
      K = K + 1
      For J = 3 To 14
        Tabl2(K, J) = Tabl1(i, J)
      Next J
    End If
  Next i
  Range("A1").Resize(NbLine, 26) = Tabl2
  Application.Calculation = iCalcul
  Application.ScreenUpdating = True
End Sub

Daniel
Cliquez pour agrandir...
Merci Daniel, ce code supprime les valeurs des colonnes A, B et celles d'apres les mois.
Mais la solution donné par Efgé répond parfaitement à mon problème.
Merci pour ton aide en tout cas :)
 
Vote positif 0 Vote négatif

Discussions similaires

E
  • Résolu(e)
XL 2019 inserer une valeur textbox dans la dernière cellule vide horizontalement
Réponses
7
Affichages
317
escudo
E
Messan
  • Résolu(e)
XL 2019 Organiser les données dans listbox
Réponses
2
Affichages
382
Messan
Messan
Usine à gaz
  • Résolu(e)
XL 2021 recherche supprimer les espaces '"si valeur cherchée est numérique" sinon NON
Réponses
7
Affichages
306
Usine à gaz
Usine à gaz
U
  • Question
Autres Enregistrer sur Onglet TOTO
Réponses
2
Affichages
377
un internaute
U
gsx-air
  • Question
Microsoft 365 Code qui ne fonctionne pas sur Excel 365
Réponses
13
Affichages
577
Staple1600
Staple1600
M
  • Résolu(e)
XL 2016 Comparaison - Ignorer les accents
Réponses
8
Affichages
487
patricktoulon
patricktoulon
kalem
  • Question
Microsoft 365 [VBA] Enchaîner déplacer lignes + supprimer les lignes vides.
Réponses
3
Affichages
583
ARMAEL
A
A
  • Question
Microsoft 365 Vba récupérer dernière valeur / dernière ligne si même valeur
Réponses
13
Affichages
967
akira21
A
U
  • Résolu(e)
Autres Mettre en couleur ligne avec VBA car MFC occupées (Excel 2003)
2
Réponses
15
Affichages
1 K
un internaute
U
M
  • Question
Microsoft 365 Programme trop lent
Réponses
12
Affichages
680
Hasco
Hasco

Membres actuellement en ligne

14 membres et 105 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 195
Messages
2 086 076
Membres
103 111
dernier inscrit
Eric68350