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

Microsoft 365 Supprimer sous-totaux négatifs dans une liste

pascalmatthys

XLDnaute Nouveau
Bonjour,

J'ai une liste avec des numéros de dossiers dinstincts, avec plusieurs lignes parfois pour le même dossier.
Dans ces lignes, des montants positifs et négatifs.
Je dois travailler uniquement les totaux positifs par dossier.
Donc concrètement dans mon fichier en annexe, par ex le dossier 500800, a deux lignes qui font un total négatif de 27 €.
Je dois trouver la formule qui me permet d'exclure ces deux lignes.

En fait il faudrait que je puisse via un sous-total par numéro de dossier, à supprimer les dossiers dont le sous-total est négatif...
Je sèche complètement...

Merci d'avance pour vos suggestions / solutions.

Pascal
 

Pièces jointes

  • fichier200923.xlsx
    24.3 KB · Affichages: 10

Gégé-45550

XLDnaute Accro
Bonjour,
Une proposition avec tableau structuré, colonnes supplémentaires et filtres.
Cordialement,
 

Pièces jointes

  • fichier200923.xlsx
    51.8 KB · Affichages: 5
Dernière édition:

tectera

XLDnaute Nouveau
Salut à tous,

Une autre solution en PJ, qui a l'avantage de fonctionner sans filtre manuel. Je suis reparti du fichier de Gégé. Par contre c'est un peu bourrin, il y a sûrement moyen de s'éviter les ASSEMB.H et PRENDRE, je suis preneur de vos conseils si vous avez plus élégant.
 

Pièces jointes

  • fichier200923bis.xlsx
    44.5 KB · Affichages: 4

job75

XLDnaute Barbatruc
Bonsoir à tous,

Cette macro crée tous les sous-totaux et supprime ceux qui sont négatifs :
VB:
Sub Sous_totaux()
Dim tablo, deb&, x, i&
Application.ScreenUpdating = False
With [A1].CurrentRegion
    .Sort .Cells(1), xlAscending, Header:=xlYes 'tri initial
    tablo = .Resize(, 2) 'matrice, plus rapide
    deb = 1: x = tablo(deb, 1)
    For i = 2 To UBound(tablo)
        If tablo(i, 1) = x Then
            tablo(i, 1) = "#N/A"
            tablo(deb, 2) = tablo(deb, 2) + tablo(i, 2)
        Else
            deb = i: x = tablo(deb, 1)
        End If
    Next
    .Resize(, 2) = tablo
    .Sort .Cells(1), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
    On Error Resume Next 'si aucune SpecialCell
    Intersect(.SpecialCells(xlCellTypeConstants, 16).EntireRow, .Cells).Delete xlUp 'supprime les doublons
    .Replace "-*", "#N/A"
    .Sort .Cells(1, 2), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
    Intersect(.SpecialCells(xlCellTypeConstants, 16).EntireRow, .Cells).Delete xlUp 'supprime les Sous-totaux négatifs
    .Sort .Cells(1), xlAscending, Header:=xlYes 'tri initial
End With
With ActiveSheet.UsedRange: End With 'actualise la barre de défilement verticale
End Sub
A+
 

Pièces jointes

  • fichier200923(1).xlsm
    34.7 KB · Affichages: 0
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour le fil, le forum,

Il y avait une erreur dans la macro précédente, je viens de la corriger.

Voici une autre solution avec ce fichier (2) : les sous totaux positifs ne sont plus affichés et les sous-totaux négatifs sont supprimés :
VB:
Sub Suppression_sous_totaux_negatifs()
Dim tablo, ub&, resu, deb&, x, i&, j&
Application.ScreenUpdating = False
With [A1].CurrentRegion
    .Sort .Cells(1), xlAscending, Header:=xlYes 'tri initial
    tablo = .Resize(, 2) 'matrice, plus rapide
    ub = UBound(tablo)
    ReDim resu(1 To ub, 1 To 1)
    deb = 1: x = tablo(deb, 1)
    For i = 2 To ub
        If tablo(i, 1) = x Then
            resu(deb, 1) = resu(deb, 1) + tablo(i, 2)
        Else
            resu(i, 1) = tablo(i, 2)
            deb = i: x = tablo(deb, 1)
        End If
    Next i
    For i = 2 To ub
        If resu(i, 1) < 0 Then
            resu(i, 1) = ""
            For j = i To ub
                If resu(j, 1) <> "" Then i = j - 1: Exit For
                resu(j, 1) = "#N/A"
            Next j
        End If
    Next i
    .Columns(1).Insert xlToRight 'insère une colonne auxiliaire
    .Columns(0) = resu 'restitution
    On Error Resume Next 'si aucune SpecialCell
    Union(.Columns(0), .Cells).Sort .Cells(1, 0), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
    Intersect(.Columns(0).SpecialCells(xlCellTypeConstants, 16).EntireRow, .Cells).Delete xlUp 'supprime les Sous-totaux négatifs
    .Columns(0).Delete xlToLeft 'supprime la colonne auxiliaire
    .Sort .Cells(1), xlAscending, Header:=xlYes 'tri initial
End With
With ActiveSheet.UsedRange: End With 'actualise la barre de défilement verticale
End Sub
A+
 

Pièces jointes

  • fichier200923(2).xlsm
    35.5 KB · Affichages: 0

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…