Additionner les cellules par valeur identique

Version imprimable

22/11/2019, 20h37
marseille13

1 pièce(s) jointe(s)

Additionner les cellules par valeur identique

Bonjour a tous,

j'ai un sérieux problème de programmation d'ont je ne maîtrise pas encore

en effet j'ai un fichier de données de colonne A à colonne R
1 - je souhaite additionner les valeur de O P Q R et afficher les sommes dans les colonnes S T U V mais la condition est:
Colonne A = valeur identique
colonne D = valeur identique
Colonne N = valeur différentes
S = SOMME(O)
T = SOMME(P)
U = SOMME(Q)
V = SOMME(R)

2 - en suite je souhaite additionner les valeurs des colonnes S T U V et afficher les sommes dans les colonne W X Y Z
mais la condition est:

colonne D = valeur identique
colonne N = valeur différentes

W = SOMME (S)
X = SOMME(T)
Y = SOMME(U)
Z = SOMME(V)

je vous met l’exemple le résultat que je souhaite obtenir dans la Pièce Jointe ci dessous
il faut le faire en VBA pas ne formule car dans le fichier j'ai au moins 500 lignes a traiter

je vous remercie d'avance pour votre aide car c un peu urgent c un travail que je dois finir avant mercredi
Pièce jointe 519165

Bonjour,

Tout d'abord, pour ce qui n'ouvrent pas les fichiers joints et qui auraient de meilleures idées, un aperçu du fichier.
Pièce jointe 519234

Une première approche

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
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
Sub Comptabiliser()
    Dim DerLig As Long, LigDep As Long
    Application.ScreenUpdating = False
 
    Columns("S:Z").ClearContents 'Effacements des résultats précédents
    Columns("S:Z").UnMerge 'Enlever les précédentes fusions de cellules
 
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
 
    '***********************************************************************************************************************
    'on fait un tri pour réunir les mêmes valeurs
    Columns("A:R").Select
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A1:A" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("D1:D" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("N1:N" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("O1:O" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("A1:R" & DerLig)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    '***********************************************************************************************************************
    'Sommes des valeurs entre chaque ligne, si A,D sont égales et N différentes
    'Traitement colonne O, total en colonne S
    LigDep = 1
    For a = 1 To DerLig - 1
        If Cells(a, "A") = Cells(a + 1, "A") And Cells(a, "D") = Cells(a + 1, "D") And Cells(a, "N") <> Cells(a + 1, "N") And Cells(a, "O") <> Cells(a + 1, "O") Then
            Cells(LigDep, "S") = Cells(a, "O") + Cells(a + 1, "O")
            LigDep = a + 2
        End If
    Next a
 
    'Traitement colonne P, total en colonne T
    LigDep = 1
    For a = 1 To DerLig - 1
        If Cells(a, "A") = Cells(a + 1, "A") And Cells(a, "D") = Cells(a + 1, "D") And Cells(a, "N") <> Cells(a + 1, "N") And Cells(a, "P") <> Cells(a + 1, "P") Then
            Cells(LigDep, "T") = Cells(a, "P") + Cells(a + 1, "P")
            LigDep = a + 2
        End If
    Next a
 
    'Traitement colonne Q, total en colonne U
    LigDep = 1
    For a = 1 To DerLig - 1
        If Cells(a, "A") = Cells(a + 1, "A") And Cells(a, "D") = Cells(a + 1, "D") And Cells(a, "N") <> Cells(a + 1, "N") And Cells(a, "Q") <> Cells(a + 1, "Q") Then
            Cells(LigDep, "U") = Cells(a, "Q") + Cells(a + 1, "Q")
            LigDep = a + 2
        End If
    Next a
 
    'Traitement colonne R, total en colonne V
    LigDep = 1
    For a = 1 To DerLig - 1
        If Cells(a, "A") = Cells(a + 1, "A") And Cells(a, "D") = Cells(a + 1, "D") And Cells(a, "N") <> Cells(a + 1, "N") And Cells(a, "R") <> Cells(a + 1, "R") Then
            Cells(LigDep, "V") = Cells(a, "R") + Cells(a + 1, "R")
            LigDep = a + 2
        End If
    Next a
 
    '***********************************************************************************************************************
    'Somme en W,X,Y,Z
    Cells(1, "W") = Application.WorksheetFunction.Sum(Range(Cells(1, "S"), Cells(DerLig, "S")))
    Cells(1, "X") = Application.WorksheetFunction.Sum(Range(Cells(1, "T"), Cells(DerLig, "T")))
    Cells(1, "Y") = Application.WorksheetFunction.Sum(Range(Cells(1, "U"), Cells(DerLig, "U")))
    Cells(1, "Z") = Application.WorksheetFunction.Sum(Range(Cells(1, "V"), Cells(DerLig, "V")))
 
    '***********************************************************************************************************************
    'Fusion des cellules communes pour une meilleure lecture
    For j = 19 To 26
        DL = DerLig
        For i = DerLig To 1 Step -1
            If Cells(i, j) <> "" Then
                Range(Cells(i, j), Cells(DL, j)).Merge
                DL = i - 1
            End If
        Next i
    Next j
    With Columns("S:Z")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
End Sub

Le fichier
Pièce jointe 519233

Cdlt

23/11/2019, 11h42
marseille13

1 pièce(s) jointe(s)

Bonjour ARTURO83

tout d'abord merci beaucoup pour ton aide.

en effet le code donne les bon résultat avec le les lignes que j'ai données en exemple visuellement pas en calcul

Pièce jointe 519261

En colonne S on voit bien que le 6 représente 3 ligne alors que c'est faux, il doit représenter deux ligne donc fusionner uniquement la ligne 2 et 3
ça sera la même chose en colonne T, U et V

enfin pour les colonnes W X Y Z
W = 52 pas 58 car la règle c'est qu'on calcul uniquement la somme si en colonne D la valeur est identique et en colonne N la valeur est différente
donc W = 45 + 7 = 52 et la fusion n'inclut pas les lignes 3, 2 et 1

ça sera la même chose pour les colonnes X, Y et 7

je te remercie d'avance pour ton aide :)
23/11/2019, 12h21
ARTURO83

Pour pouvoir tester tous les cas de figures et pour éviter d'en fabriquer un qui risque de ne pas coller à la réalité, il serait souhaitable d'avoir un fichier avec plusieurs cas de figures et si possibles avec les résultats attendus.
Pour ajouter un fichier en pièce jointe, cliquez sur l'icone "Trombone" ci-dessus.
23/11/2019, 13h41
marseille13

Citation:

Envoyé par ARTURO83

Pour pouvoir tester tous les cas de figures et pour éviter d'en fabriquer un qui risque de ne pas coller à la réalité, il serait souhaitable d'avoir un fichier avec plusieurs cas de figures et si possibles avec les résultats attendus.
Pour ajouter un fichier en pièce jointe, cliquez sur l'icone "Trombone" ci-dessus.

le problème c'est que je peux pas donner le fichier car il y a des données sensibles il est uniquement sur mon poste de bureau. Si je change le moindre fichier dur internet ils le verrons. Toutes fois que je voudrai avoir c de prendre considération la colonne D et N pour calculer les colonnes W X Y Z.
Si dans D il y plus d'une valeur identiques successivement et que dans la même ligne dans la colonne N il y a différente valeur donc je fais l'addtion des valeurs de la colonne O de la même ligne que N puis j'affiche dans colonnes W ca sera la même règle pour X Y Z
23/11/2019, 13h55
mercatog

Tu ne peux pas utiliser sous total fourni par excel si tes données sont triées bien sûr.
Le disposition sera autre mes les totaux seront mis en valeur

Voici les modifications

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
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
Sub Comptabiliser()
    Dim DerLig As Long, LigDep As Long
    Application.ScreenUpdating = False
 
    With Columns("S:Z")
        .Clear 'Effacements des résultats précédents
        .UnMerge 'Enlever les précédentes fusions de cellules
    End With
    Columns("A:Z").Interior.ColorIndex = xlNone
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
 
    '***********************************************************************************************************************
    'on fait un tri pour réunir les mêmes valeurs
    Columns("A:R").Select
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A1:A" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("D1:D" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("N1:N" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("O1:O" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("A1:R" & DerLig)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    '***********************************************************************************************************************
    'Numérotation des lignes répondant aux critères des colonnes A et D identiques et N différents
    Num = 1
    Cells(1, "AA") = Num
    For i = 2 To DerLig
        If Cells(i, "A") <> Cells(i - 1, "A") Then
            Num = Num + 1
            Cells(i, "AA") = Num
        ElseIf Cells(i, "A") = Cells(i - 1, "A") And Cells(i, "D") = Cells(i - 1, "D") And Cells(i, "N") <> Cells(i - 1, "N") Then
            Cells(i, "AA") = Num
        End If
    Next i
 
    For j = 15 To 18
        Num = 1
        For i = 1 To DerLig
            Somme = 0
            With Range(Cells(1, "AA"), Cells(DerLig, "AA"))
                Set x = .Find(Num, LookIn:=xlValues, lookat:=xlWhole)
                If Not x Is Nothing Then
                        LigX = x.Row
                    Do
                        Somme = Somme + Cells(x.Row, j)
                        Set x = .FindNext(x)
                    Loop While Not x Is Nothing And x.Row <> LigX
                    Cells(LigX, j + 4) = Somme
                End If
            End With
            Num = Num + 1
        Next i
    Next j
 
    'Numérotation des lignes répondant aux critères des colonnes D identiques et N différents
    Num = 1
    Cells(1, "AB") = Num
    For i = 2 To DerLig
        If Cells(i, "D") <> Cells(i - 1, "D") Then
            Num = Num + 1
            Cells(i, "AB") = Num
        ElseIf Cells(i, "D") = Cells(i - 1, "D") And Cells(i, "N") = Cells(i - 1, "N") Then
        ElseIf Cells(i, "D") = Cells(i - 1, "D") And Cells(i, "N") <> Cells(i - 1, "N") Then
            Cells(i, "AB") = Num
        End If
    Next i
 
    For j = 15 To 18
        Num = 1
        For i = 1 To DerLig
            Somme = 0
            With Range(Cells(1, "AB"), Cells(DerLig, "AB"))
                Set x = .Find(Num, LookIn:=xlValues, lookat:=xlWhole)
                If Not x Is Nothing Then
                        LigX = x.Row
                    Do
                        Somme = Somme + Cells(x.Row, j)
                        Set x = .FindNext(x)
                    Loop While Not x Is Nothing And x.Row <> LigX
                    Cells(LigX, j + 8) = Somme
                End If
            End With
            Num = Num + 1
        Next i
    Next j
 
    '***********************************************************************************************************************
    'Fusion des cellules communes pour une meilleure lecture
    For j = 19 To 26
        DL = DerLig
        For i = DerLig To 1 Step -1
            If Cells(i, j) <> "" Then
                Range(Cells(i, j), Cells(DL, j)).Merge
                DL = i - 1
            End If
        Next i
    Next j
 
    'Quadrillage
    With Columns("S:Z")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    Range(Cells(1, "S"), Cells(DerLig, "Z")).Borders().Weight = xlThin
    Columns("AA:AB").ClearContents
End Sub

Le fichier
Pièce jointe 519333

Cdlt

23/11/2019, 17h38
marseille13

1 pièce(s) jointe(s)

en fait ça marche beaucoup mieux, le soucis reste dans la fusion avec la 1er ligne
car j'ai modifier la ligne 1 pour pour avoir un autre résultat, le calcul est bon sauf que la ligne 2 et 3 ne sont pas fusionnée avec la ligne 1
vu que avec la modification les ligne 1 2 et 3 sont devenu un seul bloc donc ca devrait fusionner les 3 cellules

je propose un truc le mieux a force d’avancer dans le programme mettre un indicateur pour chaque bloc dans la colonne AF, BLoc1, Bloc2.....etc et grâce a ça on saura quelles sont les postions des cellules à fusionner.

possible d'avoir une correction sur ce pont STP, ci dessous le résultat
Pièce jointe 519359
cordialement

Le problème vient du fait qu'il n'y a pas de ligne de titres, j'ai donc inséré une ligne pour exécuter le programme et supprimer cette ligne à la fin pour retrouver la configuration d'origine.
Le code

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
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
Sub Comptabiliser()
    Dim DerLig As Long, LigDep As Long
    Application.ScreenUpdating = False
    Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 
    With Columns("S:Z")
        .Clear 'Effacements des résultats précédents
        .UnMerge 'Enlever les précédentes fusions de cellules
    End With
    Columns("A:Z").Interior.ColorIndex = xlNone
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
 
    '***********************************************************************************************************************
    'on fait un tri pour réunir les mêmes valeurs
    Columns("A:R").Select
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A2:A" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("D2:D" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("N2:N" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("O2:O" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("A2:R" & DerLig)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    '***********************************************************************************************************************
    'Numérotation des lignes répondant aux critères des colonnes A et D identiques et N différents
    Num = 1
    Cells(2, "AA") = Num
    For i = 3 To DerLig
        If Cells(i, "A") <> Cells(i - 1, "A") Then
            Num = Num + 1
            Cells(i, "AA") = Num
        ElseIf Cells(i, "A") = Cells(i - 1, "A") And Cells(i, "D") = Cells(i - 1, "D") And Cells(i, "N") <> Cells(i - 1, "N") Then
            Cells(i, "AA") = Num
        End If
    Next i
 
    For j = 15 To 18
        Num = 1
        For i = 3 To DerLig
            Somme = 0
            With Range(Cells(1, "AA"), Cells(DerLig, "AA"))
                Set x = .Find(Num, LookIn:=xlValues, lookat:=xlWhole)
                If Not x Is Nothing Then
                        LigX = x.Row
                    Do
                        Somme = Somme + Cells(x.Row, j)
                        Set x = .FindNext(x)
                    Loop While Not x Is Nothing And x.Row <> LigX
                    Cells(LigX, j + 4) = Somme
                'Else
                    'Cells(x.Row, j + 4) = Cells(x.Row, j)
                End If
            End With
            Num = Num + 1
        Next i
    Next j
 
    'Numérotation des lignes répondant aux critères des colonnes D identiques et N différents
    Num = 1
    Cells(2, "AB") = Num
    For i = 2 To DerLig
        If Cells(i, "D") <> Cells(i - 1, "D") Then
            Num = Num + 1
            Cells(i, "AB") = Num
        ElseIf Cells(i, "D") = Cells(i - 1, "D") And Cells(i, "N") = Cells(i - 1, "N") Then
        ElseIf Cells(i, "D") = Cells(i - 1, "D") And Cells(i, "N") <> Cells(i - 1, "N") Then
            Cells(i, "AB") = Num
        End If
    Next i
 
    For j = 15 To 18
        Num = 1
        For i = 2 To DerLig
            Somme = 0
            With Range(Cells(1, "AB"), Cells(DerLig, "AB"))
                Set x = .Find(Num, LookIn:=xlValues, lookat:=xlWhole)
                If Not x Is Nothing Then
                        LigX = x.Row
                    Do
                        Somme = Somme + Cells(x.Row, j)
                        Set x = .FindNext(x)
                    Loop While Not x Is Nothing And x.Row <> LigX
                    Cells(LigX, j + 8) = Somme
                End If
            End With
            Num = Num + 1
        Next i
    Next j
 
    '***********************************************************************************************************************
    'Fusion des cellules communes pour une meilleure lecture
    For j = 19 To 26
        DL = DerLig
        For i = DerLig To 2 Step -1
            If Cells(i, j) <> "" Then
                Range(Cells(i, j), Cells(DL, j)).Merge
                DL = i - 1
            End If
        Next i
    Next j
 
    'Quadrillage
    With Columns("S:Z")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    Range(Cells(2, "S"), Cells(DerLig, "Z")).Borders().Weight = xlThin
    Columns("AA:AB").ClearContents
    Rows("1:1").Delete Shift:=xlUp
End Sub

Le fichier
Pièce jointe 519363

23/11/2019, 19h48
marseille13

Ça marche du tonnerre; Merci beaucoup c'est vraiment très gentil :D:D
Bonne soirée à toi et bon weekend
Cordialement
B