Regroupement de cellules et calcul

[Mimosa777]

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 :

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.

 

[job75]

Re : Regroupement de cellules et calcul

Bonjour mimosa,
Pas étudié votre code en détail, mais une chose me saute aux yeux : les lignes qui définissent r devraient être placées avant les lignes If...Then qui actuellement les précèdent.
A+

 

[Mimosa777]

Re : Regroupement de cellules et calcul

Merci de votre aide mais j'ai trouver une autre solution que je mets pour ceux a qui cela interesserait un jour :

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

 

[tototiti2008]

Re : Regroupement de cellules et calcul

Bonjour à tous,

une autre façon de faire :