Votre question
Résolu

Excel bouton suppression de doublon avec condition

Tags :
  • Microsoft Excel
  • Programmation
Dernière réponse : dans Programmation
12 Décembre 2017 15:52:09

Bonjour,

J'ai de nouveau besoin de votre précieuse aide pour une macro que j'effectue. J'ai fait un bouton avec une macro qui supprime les doublons. La formule fonctionne, cependant, j'aimerais pouvoir y mettre une condition pour que la ligne gardée soit la bonne.

Ma macro est la suivante :

  1. Option Explicit
  2. Option Base 1
  3.  
  4. Sub SupprimeDoublons()
  5. Dim Plage As Range, Cell As Range
  6. Dim Un As New Collection
  7. Dim Tableau() As Integer
  8. Dim x As Integer
  9.  
  10.  
  11. Set Plage = Worksheets("Sheet1").Range("A1:A500")
  12.  
  13. On Error Resume Next
  14. For Each Cell In Plage
  15. Un.Add Cell, CStr(Cell)
  16.  
  17. If Err.Number <> 0 Then
  18. x = x + 1
  19. ReDim Preserve Tableau(1 To x)
  20. Tableau(x) = Cell.Row
  21. Err.Clear
  22. End If
  23. Next Cell
  24. On Error GoTo 0
  25. If x = 0 Then Exit Sub
  26.  
  27. Application.ScreenUpdating = False
  28.  
  29. For x = UBound(Tableau) To LBound(Tableau) Step -1
  30. Worksheets("Sheet1").Rows(Tableau(x)).EntireRow.Delete
  31. Next x
  32.  
  33. Application.ScreenUpdating = True
  34. End Sub


J'aimerais pouvoir ajouter une condition qui dit que la ligne gardée doit être celle qui a, dans la colonne 6, la valeur la plus grande.

J'espère avoir été assez clair dans mon explication et vous remercie par avance pour votre aide !

Meilleures salutations.

Stefan

Autres pages sur : excel bouton suppression doublon condition

a c 85 L Programmation
13 Décembre 2017 08:55:03

Salut, la méthode utilisé pour trouver les doublons est amusante et astucieuse :D 

Par contre elle ne facilite pas la tâche pour ton besoin :/ 
Mais bon, on va quand même y arriver ;) 
Ce qu'il faut faire:
1) lors d'une erreur : comparer la valeur de la colonne 6 de la cellule stockée et celle de la cellule en cours
2) si la cellule en cours est plus petite pas de problème, on la mais de le tableau des cellule à supprimer
3) sinon, il faut mettre la cellule stocké dans le tableau, la supprimé de la collection et ensuite stocké la cellule actuelle.

Ok maintenant on a un tableau contenant toute les lignes à supprimé, MAIS dans le désordre ! si on fait la suppression direct, c'est la cata assuré ...

Donc 2 solutions ici:

soit: on trie le tableau AVANT d'effectuer l'effacement (on trouve plein de routine quicksort sur le net)
soit: bien plus simple et rapide, on utilise la fonction UNION pour créer une RANGE contenant toutes les lignes à supprimer (et la pas besoin de le faire dans l'ordre) et on efface tout d'un coup.

Tu veux essayer par toi-même (ce serait bien) ou je te file direct la soluce ?
m
0
l
13 Décembre 2017 14:18:52

Hello drul,

Merci encore pour ta précieuse aide et conseil.

J'ai essayé de trouver une solution avec Range, mais je dois t'avouer que je rame. J'ai visiblement un souci de compréhension sur la manière de l'utiliser et de comment l'implémenter dans ma formule de base.

Si tu as plus simple et plus efficace, je suis preneur ! :-)

Merci encore pour ton aide et toute bonne semaine.
m
0
l
Contenus similaires
a c 85 L Programmation
13 Décembre 2017 15:07:16

Regarde ceci
  1. Sub SupprimeDoublons()
  2. Dim Plage As Range, Cell As Range
  3. Dim Un As New Collection
  4. Dim Tableau() As Integer
  5. Dim x As Integer
  6. Dim toErase As Range
  7.  
  8. Set Plage = Worksheets("Sheet1").Range("A1:A11")
  9.  
  10. On Error Resume Next
  11. For Each Cell In Plage
  12. Un.Add Cell, CStr(Cell)
  13.  
  14. If Err.Number <> 0 Then
  15. x = x + 1
  16. ReDim Preserve Tableau(1 To x)
  17. If Cell.Offset(0, 5).Value <= Un.Item(CStr(Cell)).Offset(0, 5).Value Then ' si la cell en cours est <= à la cell stocker
  18. Tableau(x) = Cell.Row ' on supprime la cell en cours
  19. Else 'sinon, onsupprime la cell stock et on la remplace dans la collection
  20. Tableau(x) = Un.Item(CStr(Cell)).Row
  21. Un.Remove CStr(Cell)
  22. Un.Add Cell, CStr(Cell)
  23. End If
  24.  
  25. Err.Clear
  26. End If
  27. Next Cell
  28. On Error GoTo 0
  29. If x = 0 Then Exit Sub
  30.  
  31. 'Application.ScreenUpdating = False '- inutile on efface tout d'un coup maintenant
  32.  
  33. For x = UBound(Tableau) To LBound(Tableau) Step -1 'on pourrait très bien faire la boucle à l'endroit ...
  34. If toErase Is Nothing Then 'Si la range à effacer est vide, on l'initialise
  35. Set toErase = Worksheets("Sheet1").Rows(Tableau(x)).EntireRow
  36. Else 'sinon on la complète
  37. Set toErase = Union(toErase, Worksheets("Sheet1").Rows(Tableau(x)).EntireRow)
  38. End If
  39. Next x
  40. toErase.Delete 'et finalement on détruit toue les cellules d'un coup
  41. 'Application.ScreenUpdating = True
  42. End Sub
m
0
l
13 Décembre 2017 15:44:56

J'ai essayé ton code, cependant, je dois avoir enlevé quelque chose ou adapté quelque chose de faux dans mon fichier, car quand j'utilise ma macro, sur un test de 4 lignes dont 2 fois un doublon sur la première colonne mais une différence de nombre sur la colonne 6, il m'en enlève trois au lieu de deux...

Voilà comment j'ai essayé d'adapter le code que tu m'as indiqué :
  1. Option Explicit
  2. Option Base 1
  3.  
  4.  
  5. Sub SupprimeDoublons()
  6. Dim Plage As Range, Cell As Range
  7. Dim Un As New Collection
  8. Dim Tableau() As Integer
  9. Dim x As Integer
  10. Dim toErase As Range
  11.  
  12. Set Plage = Worksheets("Base de données").Range("A1:A500")
  13.  
  14. On Error Resume Next
  15. For Each Cell In Plage
  16. Un.Add Cell, CStr(Cell)
  17.  
  18. If Err.Number <> 0 Then
  19. x = x + 1
  20. ReDim Preserve Tableau(1 To x)
  21. If Cell.Offset(0, 5).Value <= Un.Item(CStr(Cell)).Offset(0, 5).Value Then
  22. Tableau(x) = Cell.Row
  23. Else
  24. Tableau(x) = Un.Item(CStr(Cell)).Row
  25. Un.Remove CStr(Cell)
  26. Un.Add Cell, CStr(Cell)
  27. End If
  28.  
  29. Err.Clear
  30. End If
  31. Next Cell
  32. On Error GoTo 0
  33. If x = 0 Then Exit Sub
  34.  
  35. For x = UBound(Tableau) To LBound(Tableau) Step -1
  36. If toErase Is Nothing Then
  37. Set toErase = Worksheets("Base de données").Rows(Tableau(x)).EntireRow
  38. Else
  39. Set toErase = Union(toErase, Worksheets("Base de données").Rows(Tableau(x)).EntireRow)
  40. End If
  41. Next x
  42. toErase.Delete
  43. Application.ScreenUpdating = True
  44. End Sub

Par ailleurs, je t'avoues que là, je commence sincèrement à me perdre, c'est top de pouvoir faire tout ça, mais j'arrive plus vraiment à suivre avec les différents codes. Je crois que j'ai bien besoin d'un cours moi :-)

Merci en tout cas pour toute l'aide apportée jusqu'à présent, j'apprécie vraiment !
m
0
l
a c 85 L Programmation
13 Décembre 2017 16:14:06

Ta sixième colonne c'est bien la colonne F ?
Tu peux me mettre un printscreen de tes données ?
m
0
l
13 Décembre 2017 16:32:16

Oui, c'est bien la F.

Pour le printscreen, je veux bien mais il faudrait que ce soit un mp, car il y a des données confidentielles (Travail). Je te l'envoie de ce pas
m
0
l
a c 85 L Programmation
13 Décembre 2017 16:56:57

Étrange ça fonctionne bien sur mon test ...
Tu peux mettre un breakpoint ici: "Tableau(x) = Un.Item(CStr(Cell)).Row"
et voir si le programme s'y arrête ?
m
0
l

Meilleure solution

a c 85 L Programmation
14 Décembre 2017 07:57:41

Salut, j'ai regarder ton fichier.
J'avais pas saisi que les chiffres en F était stocker sous forme de texte.
Essaye de remplacer:
If Cell.Offset(0, 5).Value <= Un.Item(CStr(Cell)).Offset(0, 5).Value Then
par:
If val(Cell.Offset(0, 5).Value) <= val(Un.Item(CStr(Cell)).Offset(0, 5).Value) Then
partage
14 Décembre 2017 11:31:28

Hello drul,

Merci beaucoup !!!

C'est parfait ! ça fonctionne comme sur des roulettes !

Bonne fin de semaine et meilleures salutations.
m
0
l
a c 85 L Programmation
14 Décembre 2017 11:37:48

:jap: 
Stp clos le sujet
m
0
l