Somme sous totaux avec conditions

**hamynaa** · 15/03/2013, 15h25

Bonjour,

Est ce que quelqu'un pourrait m'aider à trouver l'erreur dans mon code pour les sous totaux. En fait il doit faire la somme des sous totaux en fonction des rating. sachant qu'on a les rating suivants (AAA), (BBB,BBB-,BBB+) qui vont ensemble (A, A+ et A-) qui vont ensemble et (AA, AA-, AA+). Le probléme est que quand je met sum if ("AA*") il prend en compte dans le total les AAA ainsi de suite. Il ne me reste que cette partie pour terminer l'automatisation.
En fait la colonne des rating = colonne C et on doit faire les sommes à partir de la colonne D jusqu'à a colone. Pour combler le tout le code marchait depuis, et maintenant il met dépassement de capacité

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
Option Explicit
 
Dim J As Long, Nblg As Long, Ligne As Long
Dim F1 As Worksheet, F4 As Worksheet, F5 As Worksheet, F6 As Worksheet
Dim Cel As Range
 
 
Sub inventaire()
Dim Lgdep As Long
Dim libelle
Dim I As Integer
 
 
 
  Application.ScreenUpdating = False
 
  libelle = Array("GOVERNMENT BONDS")
 
  Set F1 = Sheets("Inventaire")
  Set F4 = Sheets("CRDB")
  Set F5 = Sheets("Openfonds")
  Set F6 = Sheets("OPCVM")
 
 
 
  ' Si de lignes filtrées on les affiche. en fait le code ci dessous enlève les filtres mais il ne les remet pas. Peux tu m'aider à l'améliorer
  With F1
    If .FilterMode = True Then .ShowAllData
  End With
  With F4
    If .FilterMode = True Then .ShowAllData
  End With
  With F5
    If .FilterMode = True Then .ShowAllData
  End With
 With F6
    If .FilterMode = True Then .ShowAllData
  End With
 
 
 With F1.Range("A4:T336")
  .ClearContents
    .Font.Size = 10
    .Font.Bold = False
  End With
 F1.Range("V4:W1000").ClearContents
 
  Ligne = 5
 
  ' classement des obligations d'état
 
    F1.Range("B" & Ligne) = "EMPRUNT D'ETAT EUROS"
    Range("B" & Ligne).Font.Bold = True
    Ligne = Ligne + 1
libelle = Array("Government bonds")
 
Lgdep = Ligne + 1
 
  For J = 2 To F5.Range("J" & Rows.Count).End(xlUp).Row
  'If UCase(Trim(F5.Range("P" & J))) <> UCase("*indx*") Then
    Set Cel = F4.Columns("AD").Find(what:=F5.Range("J" & J), LookIn:=xlValues, lookat:=xlWhole)
    If Not Cel Is Nothing Then
            If UCase(Trim(F4.Range("C" & Cel.Row))) = UCase(libelle(I)) And _
                                  UCase(F4.Range("CL" & Cel.Row)) Like "ZONE EUROPE*" And UCase(F4.Range("BE" & Cel.Row)) = "N" Then
            F1.Range("A" & Ligne) = F5.Range("J" & J)
            F1.Range("J" & Ligne) = (F5.Range("Z" & J) / (F5.Range("Q" & J)) * 100)
            F1.Range("C" & Ligne) = F4.Range("R" & Cel.Row)
            F1.Range("D" & Ligne) = F4.Range("BS" & Cel.Row)
            F1.Range("O" & Ligne) = (F5.Range("AD" & J)) - (F5.Range("Y" & J))
 
    Set Cel = F5.Columns("J").Find(what:=F1.Range("A" & J), LookIn:=xlValues, lookat:=xlWhole)
            F1.Range("B" & Ligne) = F5.Range("P" & J)
            F1.Range("E" & Ligne) = F5.Range("AG" & J)
            F1.Range("F" & Ligne) = F5.Range("AH" & J)
            F1.Range("I" & Ligne) = F5.Range("Q" & J)
            F1.Range("K" & Ligne) = (F5.Range("AD" & J) + F5.Range("AC" & J)) / (F5.Range("Q" & J)) * 100
              F1.Range("L" & Ligne) = F5.Range("Z" & J)
              F1.Range("M" & Ligne) = F5.Range("AD" & J) - F5.Range("AC" & J)
              F1.Range("N" & Ligne) = F5.Range("AC" & J)
              F1.Range("H" & Ligne) = F5.Range("AB" & J)
              F1.Range("G" & Ligne) = Round((F5.Range("AH" & J)) / ((1 + (F5.Range("AG" & J)))), 2)
              F1.Range("T" & Ligne) = "EMPRUNT D'ETAT"
               F1.Range("V" & Ligne) = F5.Range("Y" & J)
               F1.Range("W" & Ligne) = F5.Range("AD" & J) + F5.Range("AC" & J)
               F1.Range("P" & Ligne) = F5.Range("AB" & J) + F5.Range("Z" & J)
               F1.Range("Q" & Ligne) = F5.Range("AA" & J)
               F1.Range("R" & Ligne) = ((F5.Range("Z" & J)) - (F5.Range("AC" & J)) - (F5.Range("AA" & J))) / ((Application.Sum((F5.Range("Z2").EntireColumn)) + (Application.Sum((F5.Range("AC2").EntireColumn)) + Application.Sum((F5.Range("AA2").EntireColumn)))))
               F1.Range("S" & Ligne) = ((F5.Range("AD" & J)) / ((Application.Sum((F5.Range("AD2").EntireColumn)))))
        Ligne = Ligne + 1
 
  '  End If
     End If
    End If
 
  Next J
 
 Ligne = Ligne + 1
    F1.Range("B" & Ligne) = "Sous total BBB"
     F1.Range("H" & Ligne) = Application.SumIf(Range("C" & Lgdep & ":C" & Ligne), "BBB*", Range("H" & Lgdep & ":H" & Ligne))
     F1.Range("I" & Ligne) = Application.SumIf(Range("C" & Lgdep & ":C" & Ligne), "BBB*", Range("I" & Lgdep & ":I" & Ligne))
     Ligne = Ligne + 1
 
    F1.Range("B" & Ligne) = "Sous total A"
    F1.Range("H" & Ligne) = Application.SumIf(Range("C" & Lgdep & ":C" & Ligne), "A", Range("H" & Lgdep & ":H" & Ligne))
    F1.Range("I" & Ligne) = Application.SumIf(Range("C" & Lgdep & ":C" & Ligne), "A*", Range("I" & Lgdep & ":I" & Ligne))
    Ligne = Ligne + 1
 
    F1.Range("B" & Ligne) = "Sous total AA"
    F1.Range("H" & Ligne) = Application.SumIf(Range("C" & Lgdep & ":C" & Ligne), "AA*", Range("H" & Lgdep & ":H" & Ligne))
     F1.Range("I" & Ligne) = Application.SumIf(Range("C" & Lgdep & ":C" & Ligne), "AA*", Range("I" & Lgdep & ":I" & Ligne))
    Ligne = Ligne + 1
 
    F1.Range("B" & Ligne) = "Sous total AAA"
    F1.Range("H" & Ligne) = Application.SumIf(Range("C" & Lgdep & ":C" & Ligne), "AAA*", Range("H" & Lgdep & ":H" & Ligne))
     F1.Range("I" & Ligne) = Application.SumIf(Range("C" & Lgdep & ":C" & Ligne), "AAA*", Range("I" & Lgdep & ":I" & Ligne))
    Ligne = Ligne + 1
    'le total des BBB ne prend pas le montant de la permière ligne
 
    With F1.Range("B" & Ligne)
      .Value = "TOTAL EMPRUNT D'ETAT EUROS"
      .Font.Bold = True
    End With
 
    Ligne = Ligne + 2

Le fichier est volumineux pour etre joint.
J'espère avoir été claire.

Merci pour toute votre aide

**NVCfrm** · 16/03/2013, 04h18

salut,
et si tu changeais le caractère incriminé par un autre qui ne prêterait pas à confusion ?

**hamynaa** · 19/03/2013, 13h48

Merci Ousmane pour ta réponse,

Par contre je suis vraiment débutante en VBA, vous parlez de quelle variable ?

Ligne ou ?

**NVCfrm** · 19/03/2013, 19h44

Bonsoir,

Il s'agit du critère de la fonction SumIf

Le problème étant avec le caractère générique "Astérique" tu peux le contourner en imbiquant 2 SumIf dans Sum pour tes + et -

'Exemple:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 Ma_range = WorksheetFunction.Sum(WorksheetFunction.SumIf(r.Columns(1), "A+", r.Columns(6)), _
                            WorksheetFunction.SumIf(r.Columns(1), "A-", r.Columns(6)))

j'ai noté ce commentaire dans la lecture du code qui me semble d'ailleurs coupé dans certaines, voir incomplet :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 ' Si de lignes filtrées on les affiche. en fait le code ci dessous enlève les filtres mais il ne les remet pas. Peux tu m'aider à l'améliorer

Tu pourras ajouter ces deux procédures que tu pourras faire appel :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub State_filtre(feuille_Name As String, Critere)
 
    Dim fts As AutoFilter
    Set fts = Worksheets(feuille_Name).AutoFilter '.Filters
 
    With fts.Filters
        ReDim tbF(1 To .Count, 1 To 3)
        For n = 1 To UBound(tbF)
            If .Filters(n).On Then
                tbF(n) = .Item(n).Criteria1
                If .Item(n).Operator Then tbF(n, 2) = .Item(n).Operator: tbF(n, 3) = .Item(n).Criteria2
            End If
        Next
    End With
 
End Sub
 
Sub restaure_Filtre(feuille_Name As String, Critere())
 
    Dim fts As AutoFilter
    Set fts = Worksheets(feuille_Name).AutoFilter
 
    With fts.Filters
 
        For n = 1 To .Count
            If Critere(n, 1) <> "" Then
                .Item(n).Criteria1 = Critere(n)
                If Critere(n, 2) <> "" Then .Item(n).Operator = Critere(n, 2): .Item(n).Criteria2 = Critere(n, 3)
            End If
        Next
    End With
 
    Set fts = Nothing
    Erase Critere
 
End Sub

Au début de ta procédure et à la fin les boucles suivantes:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
...
    Dim F() As String, statuts(), n As Integer
    F = Array("Inventaire", "CRDB", "Openfonds", "OPCVM")
    ReDim statuts(0 To UBound(F))
    'Pour stocker l'état du filtre si parce que tu as vraiment besoin de remettre les critérias, ce procédé néammoins tordu
    'à mon goût permettra de remettre le filtre en place:
 
    'Stocker les critères de filtre avant de les supprimer
    For n = LBound(F) To UBound(F)
        State_filtre F(n), statuts(n)
        Worksheets(F(n)).AutoFilter.ShowAllData
    Next
 
'... instructions
'...instructions
'...
 
 
'avant la fin de la procédure:
   'retablir l'état des filtres
    For n = LBound(F) To UBound(F)
        restaure_Filtre F(n), statuts(n)
    Next

'je penses que çadevrait aller ainsi.

**hamynaa** · 29/03/2013, 11h12

Merci NVCfrm,

Desolée de la réponse tardive, en fait l'automatisation fait parti de mes missions transversales. Du coup, je ne suis pas tout l temps dessus.

A bientôt pour la suite de l'aventure des nuls en VBA

Somme sous totaux avec conditions

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager