XL 2016 Suppression lignes si valeur cellule égale 0

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion KTM
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
KTM

KTM

XLDnaute Impliqué
Bonjour chers tous
Dans mon fichier joint ; je voudrais extraire et copier dans un nouveau classeur en supprimant les lignes dont le total est 0
j'ai élaboré une macro mais certains points ne fonctionnent pas bien
1- La suppression des lignes à total =0
2- La mise en page dans le nouveau classeur
Merci de bien vouloir corriger mon code ou me proposer mieux.
VB: 
Sub COPIE()
Application.ScreenUpdating = False
Dim chemin As String
Dim fichier As String, f As Worksheet,cel as range,Ls as long
chemin = ThisWorkbook.Path & "\fact\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin
    Application.ScreenUpdating = False
    Set f = ActiveWorkbook.Worksheets("fiche")
    fichier = "Extrait"
    With f
    .UsedRange.Copy
    End With
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Workbooks.Add (xlWBATWorksheet)
    Application.EnableEvents = True
    With ActiveWorkbook
    Application.ScreenUpdating = False
        With .Worksheets(1).Cells(1)
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
        End With
        Application.CutCopyMode = False
        ActiveWindow.DisplayGridlines = False
    Application.ScreenUpdating = False
    With .Sheets(1)
    Application.ScreenUpdating = False
    For Each cel In .Range("E5:E26")
    If cel.Value = 0 Then cel.Rows.Delete
    Next cel
    Ls = Range("A" & Rows.Count).End(xlUp).Row + 2
    .Columns("A:E").AutoFit
    .PageSetup.PrintArea = .Range("$A$1:$E$" & Ls).Address
    .PageSetup.Orientation = xlPortrait
    .PageSetup.FitToPagesTall = 1
    .PageSetup.FitToPagesWide = 1
    .PageSetup.RightFooter = "&P de &N"
    .PageSetup.LeftMargin = Application.InchesToPoints(0.118110236220472)
    .PageSetup.RightMargin = Application.InchesToPoints(0.118110236220472)
    End With

                     Application.ScreenUpdating = False
                     Application.DisplayAlerts = False
.SaveAs chemin & fichier, 51
.Close
End With
Set f = Nothing
End Sub
 

Pièces jointes

Trier par date Trier par votes
Bonjour @KTM,

Premier point :
Pour des suppressions de lignes, on commence toujours par la dernière ligne pour remonter vers la première. On oublie donc la boucle for Each...Next qui parcourt le range de la première ligne à la dernière. On utilise plutôt une boucle For i = DernièreLigne to PremièreLigne ... Next i (avec Step -1) :
VB: 
   For i = 26 To 5 Step -1
      If .Cells(i, "e") = 0 Then .Rows(i).Delete
   Next i


Deuxième point :
Autre erreur avec votre code initial :
monRange.Rows désigne l'ensemble des lignes du range monRange et en aucun cas les lignes entières sur l'ensemble des colonnes de la feuilles.

Dans votre cas, vous utilisez cel.rows. Comme cel est une cellule unique, l'ensemble des lignes de cel est la cellule cel elle-même. Quand vous exécutez cel.Rows.Delete, vous ne supprimez que la cellule cel et en aucun cas vous ne touchez à d'autre cellules de la ligne. Vous ne remontez donc que la colonne E. Vous pourriez utiliser cel.entirerow.delete pour supprimer une ligne entière.
 
Dernière édition:
Vote positif 0 Vote négatif
Bonjour
Ta macro corrigée
VB: 
Sub Copie()
  Application.ScreenUpdating = False
  Dim FCopie As String, FColle As String, i As Long, dl As Long
  Dim chemin As String, fichier As String
  chemin = ThisWorkbook.Path & "\fact\"
  If Dir(chemin, vbDirectory) = "" Then MkDir chemin
  fichier = "Extrait"
  FCopie = ActiveWorkbook.Name
  Application.DisplayAlerts = False
  Application.EnableEvents = False
  Application.Workbooks.Add
  FColle = ActiveWorkbook.Name
  Workbooks(FCopie).Activate
  Sheets("fiche").Select
  Sheets("fiche").Copy After:=Workbooks(FColle).Sheets(1)
  Workbooks(FColle).Sheets(1).Delete
 With Workbooks(FColle).Sheets("fiche")
  dl = .Range("E" & Rows.Count).End(xlUp).Row
   For i = dl To 5 Step -1
     If .Range("E" & i).Value = 0 Then .Range("E" & i).EntireRow.Delete
   Next
End With
  ActiveWorkbook.SaveAs chemin & fichier
  Application.DisplayAlerts = True
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub
A+ François
 
Vote positif 0 Vote négatif
Bonjour KTM, mapomme, fanfan38,

Comme ceci c'est plus propre :
VB: 
Sub COPIE()
Dim chemin As String, fichier As String, i&
chemin = ThisWorkbook.Path & "\fact\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin
fichier = "Extrait"
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier existe déjà
ThisWorkbook.Sheets("fiche").UsedRange.Copy
With Workbooks.Add(xlWBATWorksheet)
    With .Sheets(1)
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
        With Intersect(.[E:E], .UsedRange.EntireRow)
            For i = .Count To 1 Step -1
                If .Cells(i) = 0 Then .Cells(i).EntireRow.Delete
            Next i
        End With
        .Columns.AutoFit
        ActiveWindow.DisplayGridlines = False
        .PageSetup.PrintArea = .UsedRange.Address
        .PageSetup.Orientation = xlPortrait
        .PageSetup.Zoom = False
        .PageSetup.FitToPagesTall = 1
        .PageSetup.FitToPagesWide = 1
        .PageSetup.RightFooter = "&P de &N"
        .PageSetup.LeftMargin = Application.InchesToPoints(0.118110236220472)
        .PageSetup.RightMargin = Application.InchesToPoints(0.118110236220472)
    End With
    .SaveAs chemin & fichier, 51
    .Close
End With
End Sub
A+
 

Pièces jointes

Vote positif 0 Vote négatif
mapomme à dit:
Bonjour @KTM,

Premier point :
Pour des suppressions de lignes, on commence toujours par la dernière ligne pour remonter vers la première. On oublie donc la boucle for Each...Next qui parcourt le range de la première ligne à la dernière. On utilise plutôt une boucle For i = 1 to ... Next i (avec Step -1) :
VB: 
   For i = 26 To 5 Step -1
      If .Cells(i, "e") = 0 Then .Rows(i).Delete
   Next i


Deuxième point :
Autre erreur avec votre code initial :
monRange.Rows désigne l'ensemble des lignes du range monRange et en aucun cas les lignes entières sur l'ensemble des colonnes de la feuilles.

Dans votre cas, vous utilisez cel.rows. Comme cel est une cellule unique, l'ensemble des lignes de cel est la cellule cel elle-même. Quand vous exécutez cel.Rows.Delete, vous ne supprimez que la cellule cel et en aucun cas vous ne touchez à d'autre cellules de la ligne. Vous ne remontez donc que la colonne E. Vous pourriez utiliser cel.entirerow.delete pour supprimer une ligne entière.
Cliquez pour agrandir...
Bien compris et Merci !!!
 
Vote positif 0 Vote négatif
job75 à dit:
Bonjour KTM, mapomme, fanfan38,

Comme ceci c'est plus propre :
VB: 
Sub COPIE()
Dim chemin As String, fichier As String, i&
chemin = ThisWorkbook.Path & "\fact\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin
fichier = "Extrait"
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier existe déjà
ThisWorkbook.Sheets("fiche").UsedRange.Copy
With Workbooks.Add(xlWBATWorksheet)
    With .Sheets(1)
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
        With Intersect(.[E:E], .UsedRange.EntireRow)
            For i = .Count To 1 Step -1
                If .Cells(i) = 0 Then .Cells(i).EntireRow.Delete
            Next i
        End With
        .Columns.AutoFit
        ActiveWindow.DisplayGridlines = False
        .PageSetup.PrintArea = .UsedRange.Address
        .PageSetup.Orientation = xlPortrait
        .PageSetup.Zoom = False
        .PageSetup.FitToPagesTall = 1
        .PageSetup.FitToPagesWide = 1
        .PageSetup.RightFooter = "&P de &N"
        .PageSetup.LeftMargin = Application.InchesToPoints(0.118110236220472)
        .PageSetup.RightMargin = Application.InchesToPoints(0.118110236220472)
    End With
    .SaveAs chemin & fichier, 51
    .Close
End With
End Sub
A+
Cliquez pour agrandir...
Super Job75 !!
 
Vote positif 0 Vote négatif
fanfan38 à dit:
Bonjour
Ta macro corrigée
VB: 
Sub Copie()
  Application.ScreenUpdating = False
  Dim FCopie As String, FColle As String, i As Long, dl As Long
  Dim chemin As String, fichier As String
  chemin = ThisWorkbook.Path & "\fact\"
  If Dir(chemin, vbDirectory) = "" Then MkDir chemin
  fichier = "Extrait"
  FCopie = ActiveWorkbook.Name
  Application.DisplayAlerts = False
  Application.EnableEvents = False
  Application.Workbooks.Add
  FColle = ActiveWorkbook.Name
  Workbooks(FCopie).Activate
  Sheets("fiche").Select
  Sheets("fiche").Copy After:=Workbooks(FColle).Sheets(1)
  Workbooks(FColle).Sheets(1).Delete
With Workbooks(FColle).Sheets("fiche")
  dl = .Range("E" & Rows.Count).End(xlUp).Row
   For i = dl To 5 Step -1
     If .Range("E" & i).Value = 0 Then .Range("E" & i).EntireRow.Delete
   Next
End With
  ActiveWorkbook.SaveAs chemin & fichier
  Application.DisplayAlerts = True
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub
A+ François
Cliquez pour agrandir...
Merci beaucoup !!
 
Vote positif 0 Vote négatif
La suppression des lignes peut prendre du temps, il vaut mieux filtrer le tableau source :
VB: 
Sub COPIE()
Dim chemin As String, fichier As String
chemin = ThisWorkbook.Path & "\fact\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin
fichier = "Extrait"
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier existe déjà
With ThisWorkbook.Sheets("fiche").UsedRange
    .AutoFilter 5, "<>0" 'filtre automatique
    .Copy
    With Workbooks.Add(xlWBATWorksheet)
        With .Sheets(1)
            .Cells(1).PasteSpecial Paste:=xlPasteValues
            .Cells(1).PasteSpecial Paste:=xlPasteFormats
            .Cells(1).Select
            Application.CutCopyMode = False
            .Columns.AutoFit
            ActiveWindow.DisplayGridlines = False
            .PageSetup.PrintArea = .UsedRange.Address
            .PageSetup.Orientation = xlPortrait
            .PageSetup.Zoom = False
            .PageSetup.FitToPagesTall = 1
            .PageSetup.FitToPagesWide = 1
            .PageSetup.RightFooter = "&P de &N"
            .PageSetup.LeftMargin = Application.InchesToPoints(0.118110236220472)
            .PageSetup.RightMargin = Application.InchesToPoints(0.118110236220472)
        End With
        .SaveAs chemin & fichier, 51
        .Close
    End With
    .AutoFilter 'retire le filtrage
End With
End Sub
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

C
  • Question Question
Microsoft 365 Lenteur macro mise en page
Réponses
7
Affichages
85
CortoXls
C
U
  • Question Question
Autres RÉSOLU ma macro ne fonctionne pas
Réponses
3
Affichages
42
un internaute
U
C
  • Question Question
Microsoft 365 worksheet_change
2
Réponses
29
Affichages
237
CortoXls
C
D
  • Résolu(e)
Microsoft 365 Problème interférences entre macros
Réponses
14
Affichages
146
Phil69970
Phil69970
R
  • Question Question
XL 2019 Transpose et limiter nombre de valeur
Réponses
1
Affichages
338
Rabeto
R
C
  • Résolu(e)
XL 2019 Importer fichier csv sans consatener les colonnes
2 3
Réponses
34
Affichages
2 K
laurent950
laurent950
F
  • Question Question
Microsoft 365 Changement de fonctionnement d'une macro suite au passage à windows 10
Réponses
1
Affichages
492
francha62
F
E
  • Résolu(e)
Microsoft 365 Boucle sur lignes <>0
Réponses
2
Affichages
342
eric72
E
R
  • Question Question
XL 2016 excel 2016 VBA
Réponses
2
Affichages
371
rebatte
R
KTM
  • Question Question
XL 2016 Ajuster les lignes au Contenu
Réponses
4
Affichages
519
KTM
KTM
S
  • Résolu(e)
Microsoft 365 Mailing mise en forme HTML : revenir à la ligne automatique si trop de texte saisie
2
Réponses
17
Affichages
175
spike29
S
S
  • Résolu(e)
Microsoft 365 Boucle pour afficher et masquer des lignes
Réponses
12
Affichages
576
shf
S
P
  • Question Question
XL 2016 Compteur avec incrémentation de la ligne suivante
Réponses
11
Affichages
260
Pascal THIDET
P
Chaton77
  • Résolu(e)
Microsoft 365 Vba : Transférer des données d'un tableau dans un autre fichier
Réponses
7
Affichages
476
Chaton77
Chaton77
B
  • Résolu(e)
XL 2016 concours / Macro imprimer le texte au maximum selon les pages
Réponses
10
Affichages
701
berru76
B
G
  • Question Question
XL 2016 Extraire des données d'un pdf et les copier dans excel
2
Réponses
19
Affichages
1 K
kiki29
kiki29
cathodique
  • Résolu(e)
XL 2010 Problème màj feuilles depuis fichiers CSV
2
Réponses
23
Affichages
2 K
cathodique
cathodique
N
  • Question Question
Microsoft 365 Code VBA
Réponses
7
Affichages
633
TooFatBoy
TooFatBoy
Usine à gaz
  • Résolu(e)
XL 2021 recherche supprimer les espaces '"si valeur cherchée est numérique" sinon NON
Réponses
7
Affichages
589
Usine à gaz
Usine à gaz
J
  • Question Question
Microsoft 365 macro qui ouvre des fichiers excel de type "analyze in excel" généré par power bi et met à jour un filtre "mois" sur plusieurs tcd
Réponses
0
Affichages
123
JJ69
J
Retour