[XL-2010] Sous totaux en cascade

[VIPNO]

Bonjour,

Je voudrais créer une macro qui m'affiche des sous totaux en cascade. D'abord par rapport à la première colonne puis deuxième, puis quatrième, puis cinquième. J'ai crée la macro suivante mais si elle fait bien tous les sous totaux, un sous total en efface un autre .
Comme je débute en VBA, je ne suis pas capable de corriger pour obtenir réellement ce que je veux.
Est ce que l'un d'entre vous pourrait m'aider ?

D'avance merci, ce forum est une vrai mine d'information. En 2 semaines, j'ai réussi grâce à votre aide à créer quelques petits macros et à commencer automatiser mon plan de charge.
Merci encore pour cette aide précieuse....

VIPNO

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
 With Worksheets("2012_ETP_Projet")
    .UsedRange.RemoveSubtotal
 LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
 
    .Range("A2:S" & LastLig).Subtotal GroupBy:=1, Function:=xlSum, _
        TotalList:=Array(7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19), Replace:=True, PageBreaks:=False, _
        SummaryBelowData:=False
        .Range("A2:S" & LastLig).Subtotal GroupBy:=2, Function:=xlSum, _
        TotalList:=Array(7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19), Replace:=True, PageBreaks:=False, _
        SummaryBelowData:=False
        .Range("A2:S" & LastLig).Subtotal GroupBy:=4, Function:=xlSum, _
        TotalList:=Array(7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19), Replace:=True, PageBreaks:=False, _
        SummaryBelowData:=False
        .Range("A2:S" & LastLig).Subtotal GroupBy:=5, Function:=xlSum, _
        TotalList:=Array(7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19), Replace:=True, PageBreaks:=False, _
        SummaryBelowData:=False
End Wit

[mercatog]

Avec le paramètre Replace à faux
(avec boucle et pas testé)

Code :

1
2
3
4
5
6
7
8
9
10
11
Dim LastLig As Long
Dim i As Byte
 
Application.ScreenUpdating = False
With Worksheets("2012_ETP_Projet")
    .UsedRange.RemoveSubtotal
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = 1 To 5
        If i <> 3 Then .Range("A2:S" & LastLig).Subtotal GroupBy:=i, Function:=xlSum, TotalList:=Array(7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19), Replace:=False, SummaryBelowData:=1
    Next i
End With

[VIPNO]

Bonjour,

Merci pour cette réponse,
Effectivement Replace à faux permet de garder les sous totaux.
J'ai testé le code. Lorsqu'il y a une donnée c'est à dire du genre A1,B1,C1,E1. Cela se passe bien.
Mais quand on a A2,B2,C2,E2 et E'2 alors cela ne se passe pas correctement. Il y a des sous totaux qui ne se calculent pas correctement.
Je ne comprends d'ailleurs pas trop la logique de ce traitement dans ce cas.
Je joint le fichier xL, si vous y voyez plus clair....
En plus , je préfèrerai que les sous totaux soit au-dessus. Mais le résultat ne fonctionne pas non plus en mettant SummaryBelowData:=1 et en faisant un i de 5 à 1 au pas de -1.
J'ai bien peur que la fonction Subtotal ne puisse pas se faire en cascade et qu'il faille passer par autre chose...
Mais pour l'instant, je sèche....J' y verrai peut-être plus clair demain matin....
Si vous pensez à quelque chose...
Merci encore pour l'aide apportée.
VIPNO

[mercatog]

Utilise un tableau croisé dynamique

[VIPNO]

Bonjour,
Je ne souhaite pas faire de TCD car les données en entrée changent régulièrement avec des macros et je pense qu'il y aura un sac de noeud...
Bref je vais boucler.
J'ai commencé le code suivant.
Est-ce que tu peux le simplifier la copie des cellules des colonnes A à E ( il ne fait pas bon être débutant pour buter sur ce genre de pb) et j'aimerai aussi faire la somme sur les cellules G à S, je pense qu'il faut que je mette un compteur pour savoir de quelles lignes à quelles lignes je dois sommer mais .....

Merci beaucoup pour ton aide, mes questions doivent être du basic mais quand on débute....
Cordialement,
VIPNO

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
 
For i = Range("A65536").End(xlUp).Row To 3 Step -1
    If Cells(i, "E") <> Cells(i - 1, "E") Then
        Rows(i).Insert
        Cells(i, "A").Value = Cells(i + 1, "A").Value
        Cells(i, "B").Value = Cells(i + 1, "B").Value
        Cells(i, "C").Value = Cells(i + 1, "C").Value
        Cells(i, "D").Value = Cells(i + 1, "D").Value
        Cells(i, "E").Value = Cells(i + 1, "E").Value
        Cells(i, "F").Value = "BE"
       'Sommer sur les colonnes de G à S.....
    End If
Next

Bonjour,
J'ai réussi à faire une boucle pour le premier sous-total.
Le programme ne doit pas être très "propre" mais il fonctionne. Par contre j'ai déclaré SumFT As Single et du coup il me met une décimal à rallonge. Comment faire pour avoir une décimal à 2 chiffres seulement. Dans la premier ligne de calcul il me prend la valeur calculée comme une date, ce qui n'est pas Mieux...

Je vais maintenant m'atteler au sous totaux de classe supérieure....
Si vous voyez des incohérences ou si la programme peut être simplifié, n'hésitez pas à m'en faire part.
Merci à tous pour l'aide qui me fait progresser
VIPNO

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Dim Ligne As Integer, DerLigne As Integer, i As Integer
Dim Ligne2 As Integer, DerLigne2 As Integer
Dim LastLig As Long, SumFT As Single, SumFTJanv As Single
 
 
   Application.ScreenUpdating = False
'Effacer la feuille 2012_ETP_Projet
Sheets("2012_ETP_Projet").Activate
Ligne2 = Range("A1").End(xlDown).Row + 1          'efface à partir des +n lignes écrites ici 1
                                                    ' pour que la ligne compte il faut que la 1° cellule soit non vide
DerLigne2 = Range("A65536").End(xlUp).Row + 1       ' test la premiere ligne vide
 
                                                        ' A modifier pour changer le nombre de colonnes
 Range("A" & Ligne2 & ":V" & DerLigne2).ClearContents   ' efface des colonnes A à V
                                                        ' colonne A non vide pour fonctionner
 
 ' Copie des données de Feuil2 dans Feuille 2012_ETP_Projet
 'Definie la derniere ligne Personne
Sheets("Feuil2").Activate
Ligne = Range("A1").End(xlDown).Row + 1
DerLigne = Range("A65536").End(xlUp).Row + 1
 
Worksheets("Feuil2").Range("AJ" & Ligne & ":BB" & DerLigne).Copy
ActiveSheet.Paste Destination:=Worksheets("2012_ETP_Projet").Range("A" & Ligne & ":V" & DerLigne)
 
Sheets("2012_ETP_Projet").Activate ' On travaille sur la Feuille 2012_ETP_Projet
 
'Insertion des sous-totaux pour les FT au dessus du bloc
 
 
 
For i = Range("A65536").End(xlUp).Row To 3 Step -1
      SumFT = SumFT + Cells(i, "G").Value
      SumFTJanv = SumFTJanv + Cells(i, "H").Value
    If Cells(i, "E") <> Cells(i - 1, "E") Then
        Rows(i).Insert
        Cells(i, "A").Value = Cells(i + 1, "A").Value
        Cells(i, "B").Value = Cells(i + 1, "B").Value
        Cells(i, "C").Value = Cells(i + 1, "C").Value
        Cells(i, "D").Value = Cells(i + 1, "D").Value
        Cells(i, "E").Value = Cells(i + 1, "E").Value
        Cells(i, "F").Value = "BE"
        Cells(i, "G").Value = SumFT
        Cells(i, "H").Value = SumFTJanv
        SumFT = "0"
        SumFTJanv = "0"
 
 
    End If
 
Next
 
End Sub

[VIPNO]

Bonjour,

J'ai maintenant réussi à faire mes 4 sous totaux imbriqués.
Par contre j'aimerais simplifier ma macro.
Est-ce que quelqu'un pourrait m'aider pour la simplification de ce code en regroupant la formule des lignes copiées en une seule

Code :

1
2
3
4
5
6
 
Cells(i, "A").Value = Cells(i + 1, "A").Value
        Cells(i, "B").Value = Cells(i + 1, "B").Value
        Cells(i, "C").Value = Cells(i + 1, "C").Value
        Cells(i, "D").Value = Cells(i + 1, "D").Value
        Cells(i, "E").Value = Cells(i + 1, "E").Value

De même pour la formule des lignes de somme pour les cellules (i,G) et( i,H)

Code :

1
2
3
4
5
6
7
8
9
10
 
For i = Range("A65536").End(xlUp).Row To 3 Step -1
      SumFT = SumFT + Cells(i, "G").Value
      SumFTJanv = SumFTJanv + Cells(i, "H").Value
    If Cells(i, "E") <> Cells(i - 1, "E") Then
        Rows(i).Insert
         Cells(i, "G").Value = SumFT
        Cells(i, "H").Value = SumFTJanv
        SumFT = "0"
        SumFTJanv = "0"

Merci encore à tous pour l'aide apportée qui m'a permis d'automatiser un traitement répétitif et long.
Très cordialement,
VIPNO