VBA Excel additionner les cellules par valeur identique

Le 22/11/2019 à 20:30

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

97calcul.xlsx (8.64 Ko)
Le 22/11/2019 à 22:22

Salut Michel,

les deuxièmes additions ne concernent-elles pas aussi les colonnes [O-P-Q-R] et le total de [X] n'est-il pas égal à 79, plutôt ?

A+

Le 22/11/2019 à 22:56

Salut Michel, Salut curulis57 ,

voici un debut, il te reste une seule formule, ca serait bien si tu la realise toi même 

Sub FusionAddition()
On Error GoTo Errhandler
Dim rngGroupStart As Range, cell As Range
Dim Lastrow As Long, i As Long, j As Long
Application.ScreenUpdating = False
With ActiveSheet

'définir le début du groupe de depart
Set rngGroupStart = .Range("A1")
'calculer la dernière céllule de la colonne A
Lastrow = .Cells(Rows.Count, "A").End(xlUp).Row

'Annuler la fusion des cellules
.Range("S:Z").UnMerge

'Pour chaque céllule de A1:A(FIN)
For Each cell In .Range("A1:A" & Lastrow)

' Si la cellule en dessous a une valeur différente de la celle du depart
If cell.Offset(1, 0).Value <> rngGroupStart.Value Then

'Si au moins deux cellules sont affectées, démarrer le fusionnement
If (cell.Row - rngGroupStart.Row) > 0 Then

'Fusionner colonnes S,T,U et V +  insérer la somme souhaité (je te laisse à penser à la formule, voir exemple en bas)
For i = 19 To 22
.Range(.Cells(rngGroupStart.Row, i), .Cells(cell.Row, i)).Merge
.Range(.Cells(rngGroupStart.Row, i), .Cells(cell.Row, i)).Value = 1 ' ICI IL FAUT INSERER LA FORMULE
Next i
End If

'Définir le début du groupe suivant
Set rngGroupStart = cell.Offset(1, 0)
End If
Next cell

'Fusionner colonnes W,X,Y et Z +  insérer la somme des colonnes S,T,U et V
For j = 23 To 26
.Range(.Cells(1, j), .Cells(Lastrow, j)).Merge
.Range(.Cells(1, j), .Cells(Lastrow, j)).Value = Application.Sum(Range(.Cells(1, j - 4), .Cells(Lastrow, j - 4)))
Next j
.Range(.Cells(1, 19), .Cells(Lastrow, 26)).HorizontalAlignment = xlCenter
.Range(.Cells(1, 19), .Cells(Lastrow, 26)).VerticalAlignment = xlCenter

End With
Errhandler:
Application.ScreenUpdating = True
End Sub
Le 23/11/2019 à 06:24

Salut Michel,

Salut m3ellem1,

autre vision de la chose...

Pour obtenir les résultats de ton exemple, il fallait corriger, en [N1] acition en action.

Pour les résultats en [W-X-Y-Z], additionner [S-T-U-V] ou [O-P-Q-R] revient au même alors, si cet aspect du code n'est pas obligatoire...

Un double-clic sur la feuille démarre la macro.

Public Sub Calcul(ByVal iIdx%, iRow1%, iRow2%)
'
Dim tTab
'
tTab = Range("N" & iRow1 & ":R" & iRow2).Value
For x = iRow1 To iRow2
    If WorksheetFunction.CountIf(Range("N" & iRow1 & ":N" & iRow2), Cells(x, 14)) > 1 Then
        Range("N" & x & ":R" & x).Value = ""
    End If
Next
For x = 15 To 18
    iTot = WorksheetFunction.Sum(Range(Chr(64 + x) & iRow1 & ":" & Chr(64 + x) & iRow2))
    Range(Chr(64 + x + Choose(iIdx, 1, 2) * 4) & iRow1 & ":" & Chr(64 + x + Choose(iIdx, 1, 2) * 4) & iRow2).Merge
    Range(Chr(64 + x + Choose(iIdx, 1, 2) * 4) & iRow1).HorizontalAlignment = xlCenter
    Range(Chr(64 + x + Choose(iIdx, 1, 2) * 4) & iRow1).VerticalAlignment = xlCenter
    Range(Chr(64 + x + Choose(iIdx, 1, 2) * 4) & iRow1).Value = iTot
Next
Range("N" & iRow1 & ":R" & iRow2).Value = tTab
'
End Sub

A+

86michel-calcul.xlsm (17.95 Ko)
Le 23/11/2019 à 09:35
curulis57 a écrit :

Salut Michel,

les deuxièmes additions ne concernent-elles pas aussi les colonnes [O-P-Q-R] et le total de [X] n'est-il pas égal à 79, plutôt ?

A+

Bonjour curulis oui sur le fond W = le total de la colonne 0 (pareil aussi pour les X Y Z)

Le 23/11/2019 à 10:13
curulis57 a écrit :

Salut Michel,

Salut m3ellem1,

autre vision de la chose...

Pour obtenir les résultats de ton exemple, il fallait corriger, en [N1] acition en action.

Pour les résultats en [W-X-Y-Z], additionner [S-T-U-V] ou [O-P-Q-R] revient au même alors, si cet aspect du code n'est pas obligatoire...

Un double-clic sur la feuille démarre la macro.

Public Sub Calcul(ByVal iIdx%, iRow1%, iRow2%)
'
Dim tTab
'
tTab = Range("N" & iRow1 & ":R" & iRow2).Value
For x = iRow1 To iRow2
    If WorksheetFunction.CountIf(Range("N" & iRow1 & ":N" & iRow2), Cells(x, 14)) > 1 Then
        Range("N" & x & ":R" & x).Value = ""
    End If
Next
For x = 15 To 18
    iTot = WorksheetFunction.Sum(Range(Chr(64 + x) & iRow1 & ":" & Chr(64 + x) & iRow2))
    Range(Chr(64 + x + Choose(iIdx, 1, 2) * 4) & iRow1 & ":" & Chr(64 + x + Choose(iIdx, 1, 2) * 4) & iRow2).Merge
    Range(Chr(64 + x + Choose(iIdx, 1, 2) * 4) & iRow1).HorizontalAlignment = xlCenter
    Range(Chr(64 + x + Choose(iIdx, 1, 2) * 4) & iRow1).VerticalAlignment = xlCenter
    Range(Chr(64 + x + Choose(iIdx, 1, 2) * 4) & iRow1).Value = iTot
Next
Range("N" & iRow1 & ":R" & iRow2).Value = tTab
'
End Sub

A+

Bonjour michel,

merci pour ton aide mais le calcul est faux car tu n'a pas pris en considération les condition que la valeur dans A soit identique et la valeur dans D soit identique et dans N est différente

a ce moment la dans S on aura deux sommes comme dans ma PJ pareil dans T U V

puis dans la W X Y Z on aura le total des deux sommes de chaque colonne ( S T U V) suivant la condition que en colonne D la valeur est identique mais dans N la valeur est différentes

les calcul dans ma piece jointes sont bon je ne sais juste pas comment les rssortir en code

Le 23/11/2019 à 10:47
m3ellem1 a écrit :

Salut Michel, Salut curulis57 ,

voici un debut, il te reste une seule formule, ca serait bien si tu la realise toi même 

Sub FusionAddition()
On Error GoTo Errhandler
Dim rngGroupStart As Range, cell As Range
Dim Lastrow As Long, i As Long, j As Long
Application.ScreenUpdating = False
With ActiveSheet

'définir le début du groupe de depart
Set rngGroupStart = .Range("A1")
'calculer la dernière céllule de la colonne A
Lastrow = .Cells(Rows.Count, "A").End(xlUp).Row

'Annuler la fusion des cellules
.Range("S:Z").UnMerge

'Pour chaque céllule de A1:A(FIN)
For Each cell In .Range("A1:A" & Lastrow)

' Si la cellule en dessous a une valeur différente de la celle du depart
If cell.Offset(1, 0).Value <> rngGroupStart.Value Then

'Si au moins deux cellules sont affectées, démarrer le fusionnement
If (cell.Row - rngGroupStart.Row) > 0 Then

'Fusionner colonnes S,T,U et V +  insérer la somme souhaité (je te laisse à penser à la formule, voir exemple en bas)
For i = 19 To 22
.Range(.Cells(rngGroupStart.Row, i), .Cells(cell.Row, i)).Merge
.Range(.Cells(rngGroupStart.Row, i), .Cells(cell.Row, i)).Value = 1 ' ICI IL FAUT INSERER LA FORMULE
Next i
End If

'Définir le début du groupe suivant
Set rngGroupStart = cell.Offset(1, 0)
End If
Next cell

'Fusionner colonnes W,X,Y et Z +  insérer la somme des colonnes S,T,U et V
For j = 23 To 26
.Range(.Cells(1, j), .Cells(Lastrow, j)).Merge
.Range(.Cells(1, j), .Cells(Lastrow, j)).Value = Application.Sum(Range(.Cells(1, j - 4), .Cells(Lastrow, j - 4)))
Next j
.Range(.Cells(1, 19), .Cells(Lastrow, 26)).HorizontalAlignment = xlCenter
.Range(.Cells(1, 19), .Cells(Lastrow, 26)).VerticalAlignment = xlCenter

End With
Errhandler:
Application.ScreenUpdating = True
End Sub

Bonjour m3ellem1

D'abbord je te remercie pour ton code ca aide bcp

j'ai mis la formule des calcul des sommes en S T U V mais ils sont pas bon

exemple en colonne 6 il me donne 9 et 54 alors que je devrais avoir 7 et 45

voici ma formule :

Application.Sum(Range(.Cells(1, i - 4), .Cells(cell.Row, i - 4))

peux tu m'aider STP

Le 23/11/2019 à 11:20
michel90 a écrit :

Bonjour m3ellem1

D'abbord je te remercie pour ton code ca aide bcp

j'ai mis la formule des calcul des sommes en S T U V mais ils sont pas bon

exemple en colonne 6 il me donne 9 et 54 alors que je devrais avoir 7 et 45

voici ma formule :

Application.Sum(Range(.Cells(1, i - 4), .Cells(cell.Row, i - 4))

peux tu m'aider STP

c'est normal parceque comme tu l'as noté avant pour curilis il faut pas oublier la condition "dans N les valeurs sont différentes"!

avec cette formule

Application.Sum(Range(.Cells(1, i - 4), .Cells(cell.Row, i - 4))

tu calcules la somme de toutes les céllules du groupe

Bon je te donne une idée: à mon avis il faut créer un deuxième groupe pour la colonne N (le groupe qu'on utilise jusquà maintenant est relié à la colonne A) .

Le 23/11/2019 à 11:45

Salut Michel,

Salut m3ellem1,

très étonné mais tu as sans doute raison : c'est toi le patron!

Pouvons-nous avoir un fichier plus costaud et au plus près de la réalité pour travailler ?

A+

Le 23/11/2019 à 11:49

Non en fait,

dans la colonne N tu vois bien que Action et répété deux fois et sa valeur en O et répétée a ce moment la je prend un seul action et une seule valeur donc ca me fait 2 + 5 = 7

la vérité je ne sais pas comment faire ce calcul

Le 23/11/2019 à 12:46

Salut Michel,

je suppose que tu as essayé mon code sur TON fichier...

As-tu corrigé [N1] acition en action ?

A+

Le 23/11/2019 à 17:42
curulis57 a écrit :

Salut Michel,

je suppose que tu as essayé mon code sur TON fichier...

As-tu corrigé [N1] acition en action ?

A+

bonjour curulis57

OUI j'ai corrigé acition par action (faute de mon clavier mdr) puis j'ai essayé ton code mais les calculs sont pas bon vu que tu n'a pas pris en compte les conditions de calcul

celui de Me3ellem marche mais le resultat sont pas bon car il prend la somme de toute la colonne

Le 23/11/2019 à 17:52

Si c'est faux, alors, je n'ai rien compris !

32michel-calcul.xlsm (19.33 Ko)
Le 23/11/2019 à 21:26

Non mais là Curulis a bien réglé ton problème, merci à lui

Le 23/11/2019 à 21:55

Toujours rien compris : c'est bon ou pas !

Rechercher des sujets similaires à "vba additionner valeur identique"