Macro - Sous totaux automatiques

Bonjour,

Je viens à vous car je ne parviens pas à régler un problème depuis plusieurs jours.

J'ai à ma disposition une BDD énorme (réduite pour l'exemple) pour laquelle j'ai beaucoup de Pages, ainsi que plusieurs Pagepos.

Le principe étant simple : Ma BDD est triée par ordre croissant pour les pages ainsi que pour les PagesPos.

Je dois ensuite créer un sous total automatique pour chaque PagePos.

Vous pourrez voir dans mon fichier joint en BDDdebase ce que j'ai comme données initiales et en BDDvoulue ce que je souhaiterais obtenir automatiquement.

Le format du fichier doit rester intact (colonnes cachées, disposition des lignes et valeurs, etc) et la plage de sélection pour les sous totaux DOIT être de A3 à la dernière ligne (Q20 ici). De plus le sous total doit s'afficher pour les colonnes B, K, L, M, N et Q.

Je parviens à créer des sous totaux en macro, ainsi que sélectionner toutes les valeurs. Mais ce qui me pose problème c'est de combiner ces deux actions. Voici le code que j'ai travaillé et retravaillé. C'est complètement brouillon mais ce sont les différentes pistes que j'ai exploitées sans succès jusqu'à maintenant.

En espérant que mes explications et mon problème soit suffisamment clair.

Merci beaucoup pour votre aide, bonne journée !

Sub TESTEST()

ActiveSheet.Range("A5:AB5").Select
'Range("A5").End(xlUp).Select
nbLignes = Sheets("Promo semaine").Cells(Rows.Count, "A").End(xlUp).Row
'StartRange = "A5:AA5"
'EndRange = "AB5"
'Set a = Range(StartRange, Range(StartRange).End(xlDown))
'Set b = Range(EndRange, Range(EndRange).End(xlDown))
'Union(a, b).Select
Range(ActiveCell, Cells(ActiveCell.End(xlDown).Row, ActiveCell.End(x1ToRight).Column)).Select

    'lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    Selection.Subtotal GroupBy:=8, Function:=xlSum, TotalList:=Array(11, 12, 13 _
        , 14, 15, 16, 17, 28), Replace:=True, PageBreaks:=False, SummaryBelowData:= _
        True
End Sub

Bonjour,

à tester,

Sub test()
Application.DisplayAlerts = False
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A3:Q" & LastRow).Subtotal GroupBy:=8, Function:=xlSum, TotalList:=Array(11, 12, 13, 14, 15, 16, 17, 28), Replace:=True, SummaryBelowData:=True
Application.DisplayAlerts = True
End Sub

Édit: sur le fichier que vous avez transmit il n'y a rien à la colonne 28,

lors de mon test je l'ai enlevé TotalList:=Array(11, 12, 13, 14, 15, 16, 17)

Édit2: j'oubliais de joindre le fichier

Bonjour sabV,

Ça marche parfaitement merci beaucoup, et désolé pour le délai de réponse !

Bonne journée !