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

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
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 =...

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?
 

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
 

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
 

Jacky67

XLDnaute Barbatruc
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,
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:

AGDALT

XLDnaute Nouveau
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
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
 

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
 

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
 

AGDALT

XLDnaute Nouveau
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
Merci beaucoup Efgé, ce code fonctionne :D
 

Jacky67

XLDnaute Barbatruc
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
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

AGDALT

XLDnaute Nouveau
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
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 :)
 

Discussions similaires

Statistiques des forums

Discussions
315 098
Messages
2 116 200
Membres
112 683
dernier inscrit
Ramo