Microsoft 365 insérer des sous total entre chaque groupe de compte

[iliess]

Bonjour
j'ai un tableau de 6 colonne et N ligne
je cherche la méthode la plus rapide pour insérer une ligne après chaque bloque de compte avec un sous total et a la fin du tableau un total général en vba.


voici mon tableau

voici résultat souhaité

ci joint fichier démo

 

[sylvanu]

ci joint fichier démo

😅😅😅

 

[iliess]

désolé
ci joint fichier démo

 

[sylvanu]

Bonjour,
Ne serait il pas plus simple et plus lisible ( surtout sur un grand listing ) d'avoir une page des sous totaux ?
En PJ une telle approche.
La macro s'exécute automatiquement lorsqu'on sélectionne la feuille Sous totaux.

Sub Worksheet_Activate()
Cells.ClearContents
Application.ScreenUpdating = False
With Sheets("Feuil1")
    DL = .Cells(Cells.Rows.Count, "A").End(xlUp).Row
    Range("A1:A" & DL) = .Range("A1:A" & DL).Value
End With
[A:A].RemoveDuplicates Columns:=1, Header:=xlYes
DL = Cells(Cells.Rows.Count, "A").End(xlUp).Row
[B1] = "Sous totaux"
Range("B2:B" & DL).FormulaLocal = "=SOMME.SI(Feuil1!A:A;A2;Feuil1!F:F)"
Cells(DL + 2, "A") = "Total"
Cells(DL + 2, "B").FormulaLocal = "=SOMME(B2:B" & DL & ")"
[A:B].HorizontalAlignment = xlCenter
End Sub

Si vous tenez à vos Sous totaux, faites signe.

 

[Cousinhub]

Bonjour,
Hello Sylvain
Sans macro, en utilisant la fonctionnalité "Sous-Total" du ruban "Données", peut-être?

Et à cette étape, sélectionner l'emplacement du Sous-Total :
Ici, la case "Synthèse sous les données" est décochée, donc le sous-total est en début du compte
Et lycée de Versailles...

Bonne journée

 

[iliess]

Merci Mr Cousinhub
c'est exacte ce que je cherche mais en Vba car je suis entraine de préparé une petite application qui inclut ce problème

 

[Cousinhub]

Re-,
J'ai sélectionné la cellule A1, lancé l'enregistreur de macro, et effectué la manip'...
Et le code généré :

Sub Macro1()
    Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(6), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=False
End Sub

Tout simplement....

 

[iliess]

bonsoir
j'ai éditer le code suivant et marche très bien sauf j'ai bloquer dans le n qui représente la fin du boucle malgré que j'ajoute toujours un compteur n=n+1 mais le code stop dans le n initiale
est ce que je peux modifier la fin du boucle FOR

Option Explicit
Sub sous_total()
Dim i As Long, n As Long, LigneDebut As Long, LigneFin As Long
With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
End With
n = 27
LigneDebut = 2
For i = 2 To n
    If Range("A" & i + 1).Value <> Range("A" & i).Value Then
       Rows(i + 1 & ":" & i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            
            With Range("A" & i + 1 & ":F" & i + 1).Font
                .Bold = True
                .Italic = True
            End With
    
            With Range("A" & i + 1 & ":F" & i + 1).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 65535
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        
        Range("A" & i + 1).Value = "Sous Total " & Range("A" & i).Value
        LigneFin = i
        Range("F" & i + 1) = Application.WorksheetFunction.Sum(Range("F" & LigneDebut & ":F" & i))
    i = i + 1
    n = n + 1
    LigneDebut = i + 1
    End If
Next i
With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
End With

End Sub

 

[iliess]

Bonsoir
Avec un peux de patience et de détermination, j'ai réussi à atteindre mon objectif, et je tiens à partager mon code modeste. Cependant, je suis conscient qu'il existe des solutions plus efficaces et rapides. Si quelqu'un souhaite améliorer mon code, je serais reconnaissant pour ce travail constructif.
Cordialement

Option Explicit
Sub sous_total()
Dim ShCible As Worksheet
Dim i As Long, n As Long, LigneDebut As Long, LigneFin As Long
With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
End With
Set ShCible = ThisWorkbook.Worksheets("Feuil1")
LigneFin = ShCible.Cells(ShCible.Rows.Count, 1).End(xlUp).Row + 1

Range("A" & LigneFin + 1).Value = "TOTAL GENERAL"
Range("F" & LigneFin + 1).Value = Application.WorksheetFunction.Sum(Range("F2:F" & LigneFin + 2))

Range("A" & LigneFin).Value = "Sous Total " & Range("A" & LigneFin - 1).Value
            With Range("A" & LigneFin).Font
                .Bold = True
                .Italic = True
                .Name = "Calibri"
                .Size = 11
                .Strikethrough = False
                .Superscript = False
                .Subscript = False
                .OutlineFont = False
                .Shadow = False
                .Underline = xlUnderlineStyleNone
                .ThemeColor = xlThemeColorLight1
                .TintAndShade = 0
                .ThemeFont = xlThemeFontMinor
            End With
   
            With Range("A" & LigneFin & ":F" & LigneFin).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 65535
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With

For i = LigneFin - 1 To 2 Step -1
    If Range("A" & i).Value <> Range("A" & i - 1).Value Then
       Rows(i & ":" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
           
            With Range("A" & i & ":F" & i).Font
                .Bold = True
                .Italic = True
            End With
   
            With Range("A" & i & ":F" & i).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 65535
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
       
        Range("A" & i).Value = "Sous Total " & Range("A" & i - 1).Value
        Range("F" & LigneFin + 1) = Application.WorksheetFunction.Sum(Range("F" & i + 1 & ":F" & LigneFin))
    LigneFin = i
   
    End If
Next i
Rows("2:2").Delete Shift:=xlUp
With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
End With

End Sub

 

[Cousinhub]

Bonsoir,
Perso, j'ai juste une (dernière) question?
Pourquoi réinventer la roue?

 

[iliess]

Bonsoir,
Perso, j'ai juste une (dernière) question?
Pourquoi réinventer la roue?

Bonsoir
J'espérais recevoir un mot d'encouragement ou de motivation de votre part, mais je vais quand même répondre à votre question, c'est dans le but de renforcer mes compétences et mes connaissances en VBA et l'étape prochaine c'est réduire le temps exécution.

 

[chris]

Bonjour à tous

Comme cousin Hub je ne vois pas l'intérêt de reproduire ce truc obsolète et inutile.
Il a toujours été est bien plus propre d'ajouter une ou deux colonnes formulées qui donnent les sous totaux à chaque fin de série. Ce qui permet d'ajouter des lignes et, d'un clic pour trier, de retrouver instantanément ses totaux...

Quand je donne des cours VBA, je propose de résoudre des cas qui ne réinventent pas la roue...

 

[sylvanu]

Re,
"Just for the fun", pour le petit challenge d'Iliess

l'étape prochaine c'est réduire le temps exécution.

Un essai en PJ.
Sur 10 000 lignes, je passe sur mon vieux PC et mon vieil XL obsolète de 2007 de 7.5s à 0.45s.

Les deux boutons gris permettent de faire le test sur chaque algo après rapatriement de la BD qui est en feuille REF.

 

[job75]

Bonjour à tous,

Ces sous-totaux c'est le serpent de mer car il suffit d'une 7ème colonne avec cette formule en G2 :

=SI(LIGNE()=EQUIV(A2;A:A;0);SOMME.SI(A:A;A2;F:F);"")

Le recalcul des 10 000 formules se fait chez moi en 0,20 seconde, c'est plus rapide que la dernière macro de sylvanu.

A+

 

[job75]

Notez que SOMME.SI donne les bons résultats que les numéros de comptes en colonne A soient des nombres ou des textes.

Mais il vaudrait mieux que ce soient tous des nombres car EQUIV fait la différence.