Supprimer Doublons sous conditions VBA

[sharkantipav]

Bonjour,
J'essaye de supprimer des doublons par macro.... j'ai attacher un fichier test
J'ai des doublons en colonnes A. J'ai trie mon tableau par la colonnes A.
en colonne B j'ai un numero qui est unique pr chaque doublon en A.
J'aimerai garder la ligne avec le chiffre le grand en B.
Par exemple en ligne 4/5/6 j'ai la mm valeur en A et en B j'ai 0/2/3
Jaimerai donc garder uniquement la ligne 6

Merci BCP

 

[mapomme]

Re : Supprimer Doublons sous conditions VBA

Bonjour sharkantipav,

Un essai dans le fichier joint:

Sub GarderMax()
Dim nlig&, xrg As Range

  Application.ScreenUpdating = False
  nlig = Range("a" & Rows.Count).End(xlUp).Row
  Range("g:h").Insert Shift:=xlToRight
  Range("g2").FormulaR1C1 = "=N(RC[-5])"
  Range("g2:g" & nlig).FillDown
  Range("g2:g" & nlig).Value = Range("g2:g" & nlig).Value
  Range("a1:g" & nlig).Sort key1:=Range("a1"), order1:=xlAscending, _
        key2:=Range("g1"), order2:=xlAscending, Header:=xlYes
  Range("h2").FormulaR1C1 = "=1/(RC[-7]<>R[1]C[-7])"
  Range("h2:h" & nlig).FillDown
  Range("h2:h" & nlig).Value = Range("h2:h" & nlig).Value
  Range("a1:h" & nlig).Sort key1:=Range("h1"), order1:=xlAscending, Header:=xlYes
  Set xrg = Range("h1:h" & nlig).Find(What:="#DIV/0!", After:=Range("h1"), LookIn:=xlFormulas, _
          LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
          MatchCase:=False, SearchFormat:=False)
  If Not xrg Is Nothing Then Range("a" & xrg.Row & ":a" & nlig).EntireRow.Delete
  Range("g:h").Delete
  Application.ScreenUpdating = True

End Sub

 

[ROGER2327]

Re : Supprimer Doublons sous conditions VBA

Bonjour à tous.

Une autre proposition.

1. J'ai nommé le tableau (dynamique) de données "DATA". S'il porte un autre nom dans le classeur réel, il suffit de modifier la ligne

       Data = Range("DATA").Value

2. Les données n'ont pas besoin d'être ordonnées.
3. Si plusieurs lignes contiennent en colonne B la valeur maximale associée à une même clef en colonne A, elles sont conservées.

'|¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯|
'| Ajouter la référence à la bibliothèque Microsoft Scripting Runtime (scrrun.dll) au projet ! |
'|_____________________________________________________________________________________________|

Sub toto()
Dim i&, j&, v, u(), Data(), d As New Scripting.Dictionary
ReDim t(0)
  With Me.ListObjects("DATA")
    Data = Range("DATA").Value
    For i = 1 To UBound(Data)
      v = Data(i, 2): If IsEmpty(v) Or Not IsNumeric(v) Then v = 0
      If d.Exists(CStr(Data(i, 1))) Then
        u = d(CStr(Data(i, 1)))
        ReDim Preserve u(1 + UBound(u))
        u(UBound(u)) = Array(i, v)
        d(CStr(Data(i, 1))) = u
      Else
        d.Add CStr(Data(i, 1)), Array(Array(i, v))
      End If
    Next
    If Not d Is Nothing Then
      u = d.Items
      Set d = Nothing
      For i = 0 To UBound(u)
        If UBound(u(i)) <> 0 Then
          v = u(i)(0)(1)
          For j = 1 To UBound(u(i))
            If u(i)(j)(1) > v Then v = u(i)(j)(1)
          Next
          For j = 0 To UBound(u(i))
            If v > u(i)(j)(1) Then ReDim Preserve t(1 + UBound(t)): t(UBound(t)) = u(i)(j)(0)
          Next
        End If
      Next
      With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
      For i = 1 To UBound(t)
        v = t(i)
        For j = i To UBound(t)
          If v < t(j) Then t(i) = t(j): t(j) = v: v = t(i)
        Next
        .ListRows(t(i)).Delete
      Next
      With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
    End If
  End With
End Sub

Bonne journée.


ℝOGER2327
#7416

Vendredi 27 Merdre 141 (Saints Courts et Longs, gendarmes - fête Suprême Quarte)
25 Prairial An CCXXII, 1,2169h - tanche
2014-W24-5T02:55:14Z

 

[sharkantipav]

Re : Supprimer Doublons sous conditions VBA

Merci Bcp
Les 2 solutions marches bien... la 2eme est legerement plus rapide
Encore merci