Fusionner des lignes en doublon et additionner leurs valeurs

miliev83

XLDnaute Occasionnel
Bonjour,

Je n'arrive pas à adapter le code du fichier joint (1er onglet) à mon tableau (2eme onglet) :
Je précise que mon tableau à un nombre de lignes variable

Code:
 Sub SupprLigne()
Dim i As Long
    For i = ActiveSheet.Range("A65536").End(xlUp).Row To 6 Step -1
        If Cells(i, 1).Value = Cells(i - 1, 1).Value And _
            Cells(i, 2).Value = Cells(i - 1, 2).Value And _
            Cells(i, 3).Value = Cells(i - 1, 3).Value And _
            Cells(i, 4).Value = Cells(i - 1, 4).Value And _
            Cells(i, 5).Value = Cells(i - 1, 5).Value And _
            Cells(i, 10).Value = Cells(i - 1, 10).Value Then
            Cells(i - 1, 6).Value = Cells(i - 1, 6).Value + Cells(i, 6).Value
            Cells(i - 1, 7).Value = Cells(i - 1, 7).Value + Cells(i, 7).Value
            Cells(i - 1, 8).Value = Cells(i - 1, 8).Value + Cells(i, 8).Value
            Cells(i - 1, 14).Value = Cells(i - 1, 14).Value + Cells(i, 14).Value
            Cells(i, 1).EntireRow.Delete
        End If
    Next i
End Sub

J'aimerai que lorsque sur 2 lignes différentes le contenu des colonnes A D E est identique sur chaque lignes, alors ces cellules fusionnent, alors que le contenu des cellues F G H I J K L M N et AB fusionnent en s'additionnant.
La fusion doit se faire sur la même feuille car j'ai plusieurs code qui s'enchaîne.

J'ai essayé ce code mais je ne suis pas sûre du
Code:
To 2 Step -1
car je ne sais pas à quoi cela correspond au juste ? :confused: :rolleyes:

Code:
Sub SupprLigne()
Dim i As Long
    For i = ActiveSheet.Range("A65536").End(xlUp).Row To 2 Step -1
        If Cells(i, 1).Value = Cells(i - 1, 1).Value And _
            Cells(i, 4).Value = Cells(i - 1, 4).Value And _
            Cells(i, 5).Value = Cells(i - 1, 5).Value Then
            Cells(i - 1, 6).Value = Cells(i - 1, 6).Value + Cells(i, 6).Value
            Cells(i - 1, 7).Value = Cells(i - 1, 7).Value + Cells(i, 7).Value
            Cells(i - 1, 8).Value = Cells(i - 1, 8).Value + Cells(i, 8).Value
            Cells(i - 1, 9).Value = Cells(i - 1, 9).Value + Cells(i, 9).Value
            Cells(i - 1, 10).Value = Cells(i - 1, 10).Value + Cells(i, 10).Value
            Cells(i - 1, 11).Value = Cells(i - 1, 11).Value + Cells(i, 11).Value
            Cells(i - 1, 12).Value = Cells(i - 1, 12).Value + Cells(i, 12).Value
            Cells(i - 1, 13).Value = Cells(i - 1, 13).Value + Cells(i, 13).Value
             Cells(i - 1, 28).Value = Cells(i - 1, 28).Value + Cells(i, 28).Value
            Cells(i, 1).EntireRow.Delete
        End If
    Next i
End Sub

J'ai l'impression que cela fonctionne 1 fois sur 2 :mad:

Merci par avance
 
Dernière édition:

laetitia90

XLDnaute Barbatruc
Re : Fusionner des lignes en doublon et additionner leurs valeurs

bonsoir miliev83 :)
comme je comprends pour la feuille MON TABLEAU
une approche

Code:
Sub es()
  Dim t(), i As Long, m As Object, c As Byte, z
   Application.ScreenUpdating = 0
   Set m = CreateObject("Scripting.Dictionary")
   t = Range("a2:ab" & Cells(Rows.Count, 1).End(3).Row)
   For i = 1 To UBound(t)
   z = t(i, 1) & t(i, 4) & t(i, 5)
   If m.Exists(z) Then
    For c = 6 To 13:  t(m(z), c) = t(m(z), c) + t(i, c): Next c
    t(m(z), 28) = t(m(z), 28) + t(i, 28)
    Else
    x = x + 1
    For c = 1 To 28: t(x, c) = t(i, c): Next c:   m(z) = x
    End If
    Next i
    Range("a2:ab" & Cells(Rows.Count, 1).End(3).Row).ClearContents
    [a2].Resize(x, 28) = t
End Sub
 

cathodique

XLDnaute Barbatruc
Re : Fusionner des lignes en doublon et additionner leurs valeurs

Bonjour Laetitia90,

Curieux, j'ai essayé ton code sur le fichier et il fonctionne. Enfin, c'est mon avis car je ne suis pas l'initiateur de ce post.
Ton code me plait beaucoup. Alors une petite question, comment le modifier pour calculer une moyenne.

@miliev83: excuse mon intrusion

Merci. Bonne journée.
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 846
dernier inscrit
Silhabib