Calculs sous totaux par macro

[kheldar]

Bonjour à tous,

Je vous expose mon problème: sur un tableau qui fait plusieurs milliers de lignes, je souhaiterai regrouper ( sommer en fait) plusieurs lignes pour en faire un sous total mais cette action doit être effectuée sur un grand nombre de regroupements.

Ci-joint un fichier exemple vous permettant de comprendre mon besoin.
Je précise que je souhaite lancer ces calculs par macro vu le grand nombre de sous totaux à calculer. L'ordre et les valeurs des cellules de données ( lignes fournisseurs) ne doivent pas être modifiées.

Merci d'avance pour vos réponses ( une macro ) en espérant avoir été assez clair dans ma demande.

Cordialement.

 

[JCGL]

Re : Calculs sous totaux par macro

Bonjour à tous,

Un essai avec un TCD qui peut supporter un grand nombre de lignes

A toi de voir si cela peut convenir quand même

A+ à tous

 

[kheldar]

Re : Calculs sous totaux par macro

Merci JGJL,

Mais cela ne répond pas à mes besoins exactement comme je le souhaiterai.

Je réitère donc ma demande.

Merci encore.

Cordialement.

 

[job75]

Re : Calculs sous totaux par macro

Bonjour kheldar, JCGL, le forum,

Avec cette macro et le fichier :

Sub SousTotal()
Dim cel As Range, ref As Range
For Each cel In Range("B6:B" & Range("B65536").End(xlUp).Row)
If InStr(cel, "SOUS TOTAL") Then
Set ref = Range("B:B").Find(What:="SOUS TOTAl", After:=cel, LookIn:=xlValues, LookAt:=xlPart)
If ref.Row <= cel.Row Then Set ref = Range("B65536").End(xlUp)(2)
cel.Offset(, 1) = Application.Sum(Range(cel, ref.Offset(-1)).Offset(, 1))
cel.Offset(, 2) = Application.Sum(Range(cel, ref.Offset(-1)).Offset(, 2))
Set cel = ref
End If
Next
End Sub

Edit : j'avais mis < au lieu de <= (il pourrait y avoir un seul SOUS TOTAL)

A+

 

[job75]

Re : Calculs sous totaux par macro

Re,

Une autre manière de faire, probablement un peu plus rapide :

Sub SousTotal()
Dim cel As Range, ref As Range, fin As Boolean
Set cel = Range("B:B").Find(What:="SOUS TOTAl", LookIn:=xlValues, LookAt:=xlPart)
If cel Is Nothing Then Exit Sub
1 Set ref = Range("B:B").Find("SOUS TOTAl", After:=cel)
If ref.Row <= cel.Row Then Set ref = Range("B65536").End(xlUp)(2): fin = True
cel.Offset(, 1) = Application.Sum(Range(cel, ref.Offset(-1)).Offset(, 1))
cel.Offset(, 2) = Application.Sum(Range(cel, ref.Offset(-1)).Offset(, 2))
If fin Then Exit Sub
Set cel = ref
GoTo 1
End Sub

A+

 

[JCGL]

Re : Calculs sous totaux par macro

Bonjour à tous,

Puis-je me permettre ce complément pour éviter le cumul avec les valeurs précédentes ?

Option Explicit

Sub SousTotal() ' d'après Job75 sur XLD
Dim Cel As Range, Ref As Range, Fin As Boolean
Set Cel = Range("B:B").Find(What:="SOUS TOTAL", LookIn:=xlValues, LookAt:=xlPart)
If Cel Is Nothing Then Exit Sub
1 Set Ref = Range("B:B").Find("SOUS TOTAl", After:=Cel)
If Ref.Row <= Cel.Row Then Set Ref = Range("B65536").End(xlUp)(2): Fin = True
Cel.Offset(, 1).ClearContents
Cel.Offset(, 1) = Application.Sum(Range(Cel, Ref.Offset(-1)).Offset(, 1))
Cel.Offset(, 2).ClearContents
Cel.Offset(, 2) = Application.Sum(Range(Cel, Ref.Offset(-1)).Offset(, 2))
If Fin Then Exit Sub
Set Cel = Ref
GoTo 1
End Sub

A+ à tous

 

[job75]

Re : Calculs sous totaux par macro

Re,

Merci JCGL, j'avais oublié d'appuyer 2 fois sur le bouton... Travail d'équipe

Mais il y a plus simple, car je ne faisais pas les bonnes sommes :

Sub SousTotal()
Dim cel As Range, ref As Range, fin As Boolean
Set cel = Range("B:B").Find(What:="SOUS TOTAl", LookIn:=xlValues, LookAt:=xlPart)
If cel Is Nothing Then Exit Sub
1 Set ref = Range("B:B").Find("SOUS TOTAl", After:=cel)
If ref.Row <= cel.Row Then Set ref = Range("B65536").End(xlUp)(2): fin = True
cel.Offset(, 1) = Application.Sum(Range(cel.[COLOR="Red"]Offset(1) [/COLOR],ref.Offset(-1)).Offset(, 1))
cel.Offset(, 2) = Application.Sum(Range(cel.[COLOR="Red"]Offset(1) [/COLOR],ref.Offset(-1)).Offset(, 2))
If fin Then Exit Sub
Set cel = ref
GoTo 1
End Sub

Edit : bon évidemment, si entre 2 SOUS TOTAL il n'y a pas de lignes... Utiliser alors la macro corrigée par JCGL

A+

 

[job75]

Re : Calculs sous totaux par macro

Re,

Finalement une macro qui fonctionne dans tous les cas de figure, on y arrive

Sub SousTotal()
Dim cel As Range, ref As Range, fin As Boolean
Set cel = Range("B:B").Find(What:="SOUS TOTAl", LookIn:=xlValues, LookAt:=xlPart)
If cel Is Nothing Then Exit Sub
1 Set ref = Range("B:B").Find("SOUS TOTAl", After:=cel)
If ref.Row <= cel.Row Then Set ref = Range("B65536").End(xlUp)(2): fin = True
cel.Offset(, 1) = Application.Sum(Range(cel, ref.Offset(-1)).Offset(, 1)) [COLOR="Red"]- cel.Offset(, 1)[/COLOR]
cel.Offset(, 2) = Application.Sum(Range(cel, ref.Offset(-1)).Offset(, 2)) [COLOR="Red"]- cel.Offset(, 2)[/COLOR]
If fin Then Exit Sub
Set cel = ref
GoTo 1
End Sub

Note : j'ai relooké le fichier par copier-coller (nombre de Ko)

A+

 

[kheldar]

Re : Calculs sous totaux par macro

Bonjour à tous,

Merci à job75 et à JGCL pour leurs réponses.

Ca y est presque.


En effet, si entre 2 SOUS TOTAL il n'y a pas de lignes, eh bien sur ces lignes, la macro ne met des 0 à la place des valeurs.

Merci beaucoup pour toutes vos réponses, à part le petit problème ci-dessus, cela fonctionne parfaitement.

Débloquer moi ce problème, svp.
Je n'y arrive pas même en décortiquant la macro présentée par job75 et en l'améliorant avec celle de JGCL

Merci à vous.

Cordialement.

 

[JCGL]

Re : Calculs sous totaux par macro

Bonjour à tous,

Peux-tu essayer avec ce code :

Option Explicit
Sub SousTotal()
Dim cel As Range, ref As Range, fin As Boolean
Set cel = Range("B:B").Find(What:="SOUS TOTAL", LookIn:=xlValues, LookAt:=xlPart)
If cel Is Nothing Then Exit Sub
1 Set ref = Range("B:B").Find("SOUS TOTAL", After:=cel)
If ref.Row <= cel.Row Then Set ref = Range("B65536").End(xlUp)(2): fin = True
cel.Offset(, 1) = Format(Application.Sum(Range(cel, ref.Offset(-1)).Offset(, 1)) - cel.Offset(, 1), "###0.00")
cel.Offset(, 2) = Format(Application.Sum(Range(cel, ref.Offset(-1)).Offset(, 2)) - cel.Offset(, 2), ".000%;;")
If fin Then Exit Sub
Set cel = ref
GoTo 1
End Sub

A+ à tous

 

[kheldar]

Re : Calculs sous totaux par macro

Bonjour JCGL,

Je viens d'essayer ton code, et malheureusement, cela ne résout pas le problème.

Le soucis vient du fait que si il n'y a pas de lignes à additionner en dessous de la ligne SOUS TOTAL, la macro n'arrive pas à passer au-dessus du reste du calcul.

Argghhhh, juste cela qui bloque mon analyse; je n'arrive vraiment pas à trouver le test qui fait que si la ligne inférieure est également SOUS TOTAL, alors la macro doit passer au SOUS TOTAL suivant sans changer les valeurs de cette ligne SOUS TOTAL seule.

J'espère pouvoir trouver ou obtenir ( grâce au forum ) une solution.

Merci d'avance pour tout.

Cordialement.

 

[job75]

Re : Calculs sous totaux par macro

Bonjour kheldar, JCGL,

Fallait préciser peut-être avant, non ?

Alors avec juste un petit test supplémentaire :

Sub SousTotal()
Dim cel As Range, ref As Range, fin As Boolean
Set cel = Range("B:B").Find(What:="SOUS TOTAL", LookIn:=xlValues, LookAt:=xlPart)
If cel Is Nothing Then Exit Sub
1 Set ref = Range("B:B").Find("SOUS TOTAL", After:=cel)
If ref.Row <= cel.Row Then Set ref = Range("B65536").End(xlUp)(2): fin = True
[COLOR="Red"]If ref.Row > cel.Row + 1 Then[/COLOR]
cel.Offset(, 1) = Application.Sum(Range(cel.Offset(1) ,ref.Offset(-1)).Offset(, 1))
cel.Offset(, 2) = Application.Sum(Range(cel.Offset(1) ,ref.Offset(-1)).Offset(, 2))
[COLOR="Red"]End If[/COLOR]
If fin Then Exit Sub
Set cel = ref
GoTo 1
End Sub

A+

 

[kheldar]

Re : Calculs sous totaux par macro

Bonjour job75

Je viens de lancer le test et cela fonctionne parfaitement comme je le souhaite.

Je vous remercie beaucoup Messieurs ( job75 et JCGL), grâce à vous je vais gagner à peu près 20 heures de traitement fastidieux qui maintenant en un clic me donne les calculs ( et bien évidemment les résultats ) attendus.

Encore merci , et je peux vous aider dans la mesure de mes possiblités, j'en serai ravi.

Cordialement.