Suppression et addition de doublons

[JMR150]

Bonjour à tous,

Je rencontre un problème avec mon fichier. En effet, je cherche à supprimer les doublons et à additionner les valeurs correspondantes. J'ai écrit mon code comme suit :

Sub supDoublonsTotal()
With Sheets("Feuil2")
Dim L_fin As Integer
L_fin = Range("A65536").End(xlUp).Row
  ligne = 1
  Range(Cells(1, 1), Cells(L_fin, 1)).Sort Key1:=Cells(L_fin, 1), Order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
  Do While Cells(ligne, 1) <> ""
     If Cells(ligne, 1) = Cells(ligne + 1, 1) Then
        Cells(ligne, 2) = Cells(ligne, 2) + Cells(ligne + 1, 2)
        Rows(ligne + 1).Delete
     Else
        ligne = ligne + 1
     End If
  Loop
End With
End Sub

Petit hic : en faisant quelques essais, j'ai remarqué que le code marchait très bien sans la partie de tri des valeurs :

Range(Cells(1, 1), Cells(L_fin, 1)).Sort Key1:=Cells(L_fin, 1), Order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Il faut donc que je passe par le tri manuel des valeurs. Je voudrais éviter cette manipulation car je compte utiliser ce code pour un tableau beaucoup plus important.

Pouvez-vous me dire ce qui cloche s'il vous plaît ?

Merci d'avance

 

[frangy]

Re : Suppression et addition de doublons

Bonjour,

Essaie comme cela

Sub supDoublonsTotal()
Dim L_fin As Long, Ligne As Long
    With Sheets("Feuil2")
        L_fin = .Range("A65536").End(xlUp).Row
        .Range(.Cells(1, 1), .Cells(L_fin, 1)).Sort Key1:=.Cells(L_fin, 1), Order1:=xlDescending, Header:= _
            xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        For Ligne = L_fin To 2 Step -1
           If .Cells(Ligne, 1) = .Cells(Ligne - 1, 1) Then
              .Cells(Ligne - 1, 2) = .Cells(Ligne, 2) + .Cells(Ligne - 1, 2)
              .Rows(Ligne).Delete
           End If
        Next Ligne
    End With
End Sub

A+

 

[JMR150]

Re : Suppression et addition de doublons

Même problème : les données ne sont pas cohérentes.
Par exemple pour "T" qui revient deux fois, la somme devrait être égale à 11. Et quand j'exécute la macro, ça donne 80.
Quand je mets la partie du tri en commentaire dans le code et que je trie manuellement la colonne A en Feuil2, là y'a pas de soucis, ça additionne correctement.
Je ne comprends pas

 

[JMR150]

Re : Suppression et addition de doublons

J'ai finalement trouvé une solution, même si elle n'est pas très propre car elle parcourt toute la colonne en ne détectant pas la dernière ligne mais elle parcourt le fichier jusqu'à la ligne 65536.. Bon pas très subtil mais au moins ça marche.

Sub supDoublonsTotal()
With Sheets("Feuil2")
ligne = 1
With ActiveWorkbook.Worksheets("Feuil2").Sort
        .SetRange Range("A1:B65536")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
End With
  Do While Cells(ligne, 1) <> ""
     If Cells(ligne, 1) = Cells(ligne + 1, 1) Then
        Cells(ligne, 2) = Cells(ligne, 2) + Cells(ligne + 1, 2)
        Rows(ligne + 1).Delete
     Else
        ligne = ligne + 1
     End If
  Loop
End With
End Sub

Si vous avez mieux, je suis preneuse

 

[frangy]

Re : Suppression et addition de doublons

Effectivement, il faut que la plage prenne en compte les 2 colonnes

        .Range(.Cells(1, 1), .Cells(L_fin, 2)).Sort Key1:=.Cells(L_fin, 1), Order1:=xlDescending, Header:= _
            xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal

A+

 

[JMR150]

Re : Suppression et addition de doublons

Ok je prends note de la réponse et j'essaye

 

[JMR150]

Re : Suppression et addition de doublons

Ca marche nickel, merci beaucoup

 

[laetitia90]

Re : Suppression et addition de doublons

bonjour tous
on pourrait ecrire comme cela egalement

Sub es()
  Dim t(), i As Long, m As Object
  Set m = CreateObject("Scripting.Dictionary")
  With Feuil3
  t = .Range("a1:b" & .Cells(Rows.Count, 1).End(3).Row)
  For i = 1 To UBound(t)
  m(t(i, 1)) = m(t(i, 1)) + t(i, 2)
  Next i
  .Range("a1:b" & .Cells.Find("*", , , , , xlPrevious).Row).ClearContents
  .[a1].Resize(m.Count) = Application.Transpose(m.keys)
  .[b1].Resize(m.Count) = Application.Transpose(m.Items)
  .[a1:b100000].Sort Key1:=.[a1], Order1:=xlAscending, Header:=xlGuess
  End With
End Sub