Somme dans cellule

Version imprimable

Somme dans cellule

Bonjour a tous,

voulant tout simplement eviter les tableaux croisés dynamiques, je désire faire un calcul qui me permettrait de regrouper plusieurs lignes dans une feuille de calcul contenant la meme valeur dans un champ en particulier et faire la somme du contenu des restes des cellules de cette meme ligne.

Mon code fonctionne presque parfait mais je n'arrive pas a trouver le petit probleme qui foire le calcul a un moment donné.

Voici mon tableau de donné de depart:
projet|cout|amortissement|type
projetA|125|25|N
projetA|126|35|N
projetA|127|45|N
projetA|128|55|D
projetB|129|65|D
projetC|130|75|F
projetC|131|85|F
projetC|132|95|F

et voici le resultat souhaité :
projetA|378|105|N
projetA|128|55|D
projetB|129|65|D
projetC|393|255|F

mais voici ce qu'il me retourne grace a mon code :
projetA|506|160|D
projetB|129|65|D
projetC|393|255|F

Vous remarquerez qu'il calcul la 4eme ligne (projet A) avec les N et remplace le N par un D. Ca me rend dingue, je comrpends pas pourquoi et j'ai tout essayer.

Voici ma macro :

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
Sub test()
Dim i As Integer, r As Integer
Sheet3.Range("A2:E65535").ClearContents
For i = 2 To Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
        If Sheet2.Cells(i, 4) = "N" Then
            If Sheet2.Cells(i, 1) <> Sheet2.Cells(i - 1, 1) Then
                r = Sheet3.Cells(Rows.Count, 1).End(xlUp)(2).Row
                Sheet3.Cells(r, 1) = Sheet2.Cells(i, 1)
                Sheet3.Cells(r, 2) = Sheet2.Cells(i, 2)
                Sheet3.Cells(r, 3) = Sheet2.Cells(i, 3)
                Sheet3.Cells(r, 4) = Sheet2.Cells(i, 4)
            Else
                Sheet3.Cells(r, 1) = Sheet2.Cells(i, 1)
                Sheet3.Cells(r, 2) = Sheet3.Cells(r, 2) + Sheet2.Cells(i, 2)
                Sheet3.Cells(r, 3) = Sheet3.Cells(r, 3) + Sheet2.Cells(i, 3)
                Sheet3.Cells(r, 4) = Sheet2.Cells(i, 4)
            End If
        ElseIf Sheet2.Cells(i, 4) = "D" Then
            If Sheet2.Cells(i, 1) <> Sheet2.Cells(i - 1, 1) Then
                r = Sheet3.Cells(Rows.Count, 1).End(xlUp)(2).Row
                Sheet3.Cells(r, 1) = Sheet2.Cells(i, 1)
                Sheet3.Cells(r, 2) = Sheet2.Cells(i, 2)
                Sheet3.Cells(r, 3) = Sheet2.Cells(i, 3)
                Sheet3.Cells(r, 4) = Sheet2.Cells(i, 4)
            Else
                Sheet3.Cells(r, 1) = Sheet2.Cells(i, 1)
                Sheet3.Cells(r, 2) = Sheet3.Cells(r, 2) + Sheet2.Cells(i, 2)
                Sheet3.Cells(r, 3) = Sheet3.Cells(r, 3) + Sheet2.Cells(i, 3)
                Sheet3.Cells(r, 4) = Sheet2.Cells(i, 4)
            End If
        ElseIf Sheet2.Cells(i, 4) = "F" Then
            If Sheet2.Cells(i, 1) <> Sheet2.Cells(i - 1, 1) Then
                r = Sheet3.Cells(Rows.Count, 1).End(xlUp)(2).Row
                Sheet3.Cells(r, 1) = Sheet2.Cells(i, 1)
                Sheet3.Cells(r, 2) = Sheet2.Cells(i, 2)
                Sheet3.Cells(r, 3) = Sheet2.Cells(i, 3)
                Sheet3.Cells(r, 4) = Sheet2.Cells(i, 4)
            Else
                Sheet3.Cells(r, 1) = Sheet2.Cells(i, 1)
                Sheet3.Cells(r, 2) = Sheet3.Cells(r, 2) + Sheet2.Cells(i, 2)
                Sheet3.Cells(r, 3) = Sheet3.Cells(r, 3) + Sheet2.Cells(i, 3)
                Sheet3.Cells(r, 4) = Sheet2.Cells(i, 4)
            End If
            End If
 
Next
 
End Sub

Votre aide sera très apprécié. Merci d'avance.

Bonjour,

Essaie ceci

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
 
Sub triDonnees()
    Sheets("Sheet2").Select
    Columns("A:D").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("D1"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub
 
Sub traitement()
    Dim i, j As Integer
    Dim typeProjet, typeLettre As String
    Call triDonnees
    i = 1
    j = 1
    typeProjet = ""
    typeLettre = ""
    While Trim(Sheets("Sheet2").Cells(i, 1).Value) <> ""
        If typeProjet <> Sheets("Sheet2").Cells(i, 1).Value Or typeLettre <> Sheets("Sheet2").Cells(i, 4).Value Then
            Sheets("Sheet3").Cells(j, 1).Value = Sheets("Sheet2").Cells(i, 1).Value
            Sheets("Sheet3").Cells(j, 2).Value = Sheets("Sheet2").Cells(i, 2).Value
            Sheets("Sheet3").Cells(j, 3).Value = Sheets("Sheet2").Cells(i, 3).Value
            Sheets("Sheet3").Cells(j, 4).Value = Sheets("Sheet2").Cells(i, 4).Value
            typeProjet = Sheets("Sheet2").Cells(i, 1).Value
            typeLettre = Sheets("Sheet2").Cells(i, 4).Value
            j = j + 1
        Else
            Sheets("Sheet3").Cells(j - 1, 2).Value = Sheets("Sheet3").Cells(j - 1, 2).Value + Sheets("Sheet2").Cells(i, 2).Value
            Sheets("Sheet3").Cells(j - 1, 3).Value = Sheets("Sheet3").Cells(j - 1, 3).Value + Sheets("Sheet2").Cells(i, 3).Value
        End If
        i = i + 1
    Wend
End Sub

Ca au au moins le mérite de te permetttre de mettre autre chose que N,D ouF à l'avenir... Le prog marchera toujours sans que tu aies besoin de réécrire le même genre de ligne à chaque fois

14/10/2008, 17h36
Mimosa777

un gros merci Helios77, ca marche a merveille ta methode. Ca va m'aider enormement.
Merci encore :yaisse2::king: