Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Agald,
Peut être en accélérant la somme :
VB: 
For i = NbLine To 1 Step -1
    Set Plage = Range(Cells(i, 3), Cells(i, 14))
    If Sum(Plage) = 0 Then Rows(i).Delete
Next i
Ce sera plus rapide que de faire 14 AND.
Mais cela sera t-il suffisant ?
 
Vote positif 0 Vote négatif
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

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

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
Merci beaucoup Efgé, ce code fonctionne
 
Vote positif 0 Vote négatif

Jacky67

XLDnaute Barbatruc
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
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
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
E
  • Résolu(e)
XL 2019 inserer une valeur textbox dans la dernière cellule vide horizontalement
Réponses
7
Affichages
581
escudo
E
  • Résolu(e)
XL 2019 Organiser les données dans listbox
Réponses
2
Affichages
691
Messan
  • Résolu(e)
XL 2021 recherche supprimer les espaces '"si valeur cherchée est numérique" sinon NON
Réponses
7
Affichages
572
Usine à gaz
U
  • Question
Autres Enregistrer sur Onglet TOTO
Réponses
2
Affichages
502
un internaute
U
  • Question
Microsoft 365 Code qui ne fonctionne pas sur Excel 365
Réponses
13
Affichages
833
Staple1600
M
  • Résolu(e)
XL 2016 Comparaison - Ignorer les accents
Réponses
8
Affichages
774
patricktoulon
  • Suggestion
Texte Définir les propriétés d'une cellule ou d'un Range (couleurs, fonte, ..., valeur) dans une formule
Réponses
0
Affichages
972
Dudu2
  • Question
Microsoft 365 [VBA] Enchaîner déplacer lignes + supprimer les lignes vides.
Réponses
3
Affichages
795
ARMAEL
A
A
  • Question
Microsoft 365 Vba récupérer dernière valeur / dernière ligne si même valeur
Réponses
13
Affichages
1 K
akira21
A
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…