[Résolu]Repérer (puis supprimer) des doublons ligne par ligne

K

Kiriko

XLDnaute Occasionnel
Bonjour à tous,

Dans une plage de données (de 4000 lignes), je cherche à repérer (mise en surbrillance bleue?) les valeurs qui sont en double (ou plus) sur une même ligne (plus précisément à partir de la colonne K jusqu'à la colonne BH. En excluant les cellules vides.

Le plus serait d'avoir la possibilité de les supprimer ensuite automatiquement (toujours sans intégrer les cellules vides, ceci afin que chaque donnée non doublonnée reste précisément à sa place)

Le fichier joint de quelques lignes donne un exemple du 1er résultat souhaité...

Merci par avance !
 

Pièces jointes

  • Doublons lignes.xlsx
    13.1 KB · Affichages: 106
Dernière édition:
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : Repérer (puis supprimer) des doublons ligne par ligne

Bonjour Kiriko,

Pour le repérage des doublons, une Mise en forme conitionnelle (MFC) s'impose :

- sélectionner la plage K2:BH8

- formule de la MFC (K2 étant la cellule active) :

Code: 
=LN(NB.SI($K2:$BH2;K2))
A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Repérer (puis supprimer) des doublons ligne par ligne

Re,

Maintenant pour effacer les doublons cette macro :

Code: 
Sub EffaceDoublons()
Dim r As Range, n As Integer, i As Integer
Set r = [K2:BH8] 'à adapter
n = r.Columns.Count
For Each r In r.Rows
  For i = n To 2 Step -1
    If Application.CountIf(r, r.Cells(i)) > 1 Then r.Cells(i) = ""
  Next
Next
End Sub
La valeur la plus à gauche est la seule conservée.

Edit : ajouté la variable n, pour gagner un peu de temps.

A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Repérer (puis supprimer) des doublons ligne par ligne

Re,

Testé avec le tableau recopié (avec la MFC) jusqu'à la ligne 4201 :

Code: 
Sub EffaceDoublons()
Dim r As Range, n As Integer, i As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set r = [K2:BH4201] 'à adapter
n = r.Columns.Count
For Each r In r.Rows
  For i = n To 2 Step -1
     If Application.CountIf(r, r.Cells(i)) > 1 Then r.Cells(i) = ""
  Next
Next
Application.Calculation = xlCalculationAutomatic
End Sub

Sur Win 7/Excel 2010 la durée d'exécution est de 5,2 secondes.

Edit : avec un test supplémentaire sur les cellules vides, la durée se réduit à 3,2 secondes :

Code: 
Sub EffaceDoublons()
Dim t, r As Range, n As Integer, i As Integer
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set r = [K2:BH4201] 'à adapter
n = r.Columns.Count
For Each r In r.Rows
  For i = n To 2 Step -1
    If r.Cells(i) <> "" Then _
      If Application.CountIf(r, r.Cells(i)) > 1 Then r.Cells(i) = ""
  Next
Next
Application.Calculation = xlCalculationAutomatic
MsgBox Timer - t
End Sub
A+
 
Dernière édition:
Vote positif 0 Vote négatif
K

Kiriko

XLDnaute Occasionnel
Re : Repérer (puis supprimer) des doublons ligne par ligne

Bonsoir job75 !
Tu combles mes espérances et en plus, très rapidement !
Mille merci !!
Tout ceci est parfait...
Je me doutais bien qu'une Mfc était la solution, mais aucune idée de la formule...
Encore merci !!
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Repérer (puis supprimer) des doublons ligne par ligne

Bonjour Kiriko,

Il suffit de compter les effacements...

Et avec un tableau VBA c'est encore plus rapide.

Sur les données copiées jusquà la ligne 4201 => 0,82 seconde :

Code: 
'si l'on compare des textes, on ignore la casse
Option Compare Text

Sub EffaceDoublons()
Dim t, r As Range, tablo, n%, i&, j%, k%, doublon&
t = Timer
Set r = [K2:BH4201] 'à adapter
tablo = r
n = UBound(tablo, 2)
For i = 1 To UBound(tablo)
  For j = 1 To n - 1
    If tablo(i, j) <> "" Then
      For k = j + 1 To n
        If tablo(i, k) = tablo(i, j) _
          Then tablo(i, k) = "": doublon = doublon + 1
      Next
    End If
  Next
Next
r = tablo
MsgBox "Doublons supprimés " & doublon & vbLf & _
  "Durée " & Format(Timer - t, "0.00 \s")
End Sub
A+
 
Vote positif 0 Vote négatif
K

Kiriko

XLDnaute Occasionnel
Re : Repérer (puis supprimer) des doublons ligne par ligne

Bonjour job75 !
Quelle réactivité, merci beaucoup !!!
C'est parfait !!
J'aurais d'autres problématiques sur ce type de fichier (MFC selon nombre d'heures d'un N° à une date,....) mais je vais créer un nouveau poste pour cela...

Encore merci !!

Edit : Bonjour MJ13 !!
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : [Résolu]Repérer (puis supprimer) des doublons ligne par ligne

Bonjour Kiriko, MJ13 :) le forum,

Quand on parle de doublon l'objet Dictionary est normalement incontournable.

Cette solution est donc un peu plus rapide (surtout s'il y a peu de cellules vides) :

Code: 
Sub EffaceDoublons()
Dim t, r As Range, tablo, n%, d As Object, i&, j%, x$, doublon&
t = Timer
Set r = [K2:BH4201] 'à adapter
tablo = r
n = UBound(tablo, 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo)
  d.RemoveAll
  For j = 1 To n
    If tablo(i, j) <> "" Then
      x = LCase(tablo(i, j))
      If d.Exists(x) Then
        tablo(i, j) = ""
        doublon = doublon + 1
      Else
        d.Add x, x
      End If
    End If
  Next
Next
r = tablo
MsgBox "Doublons supprimés " & doublon & vbLf & _
  "Durée " & Format(Timer - t, "0.00 \s")
End Sub
Edit : LCase => pour ignorer la casse sur du texte.

A+
 
Dernière édition:
Vote positif 0 Vote négatif
K

Kiriko

XLDnaute Occasionnel
Re : [Résolu]Repérer (puis supprimer) des doublons ligne par ligne

Bonjour job75 !
Encore merci, quand tu te penches sur un sujet, tu ne fais pas semblant dis-donc...
Par contre, il est vrai que j'ai souvent beaucoup de cellules vides...
Est-ce que le fait "d'adapter" la dernière ligne prise en compte (ici la 4201) à la "dernière ligne non vide", ou à la dernière ligne où la colonne H est non vide? (pas la première, bien la dernière) pourrais faire gagner du temps ou bien la recherche de cette ligne fait perdre le temps gagner ?? Ceci juste pour ma culture personnelle car le temps de traitement actuel me convient déjà parfaitement...
Par contre, je me rends compte que pour la suite du traitement de ces données, la présence de cellules contenant un ou plusieurs espaces est problématique. Grâce à l'enregistreur de macros, j'ai rajouté :
Code: 
Columns("K:BH").Select
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
Si tu veux bien me donner ton avis dessus, et me dire éventuellement si une autre méthode convient pour cela...
Avec tous mes remerciements encore !!

P.S. : J'ai également posé un post concernant le même fichier :
https://www.excel-downloads.com/threads/reperer-depassements-damplitude-horaire-13h.192876/

Mais ma demande semble trop mal expliquée et trop ambitieuse peut-être (beaucoup de consultations sans réponses ni demandes de précisions), je vais donc l'éditer (et revoir mes souhaits à la baisse)...
En tout cas, je n'aurais de cesse de remercier les forumeurs passionnés tels que toi qui viennent en aide à de parfaits inconnus, et cela gracieusement en plus...
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : [Résolu]Repérer (puis supprimer) des doublons ligne par ligne

Re Kiriko,

Pour les 2 points en question, voyez les lignes 4 et 5 de ce code :

Code: 
Sub EffaceDoublons()
Dim t, r As Range, tablo, n%, d As Object, i&, j%, x$, doublon&
t = Timer
Set r = Range("K2:BH" & Cells(Rows.Count, "H").End(xlUp).Row)
r.Replace " ", "", xlPart 'supprime les espaces
tablo = r
n = UBound(tablo, 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo)
  d.RemoveAll
  For j = 1 To n
    If tablo(i, j) <> "" Then
      x = LCase(tablo(i, j))
      If d.Exists(x) Then
        tablo(i, j) = ""
        doublon = doublon + 1
      Else
        d.Add x, x
      End If
    End If
  Next
Next
r = tablo
MsgBox "Doublons supprimés " & doublon & vbLf & _
  "Durée " & Format(Timer - t, "0.00 \s")
End Sub
A+
 
Vote positif 0 Vote négatif
K

Kiriko

XLDnaute Occasionnel
Re : [Résolu]Repérer (puis supprimer) des doublons ligne par ligne

Bonsoir job75, et merci beaucoup, c'est encore parfait.
Mes excuses pour le tutoiement, c'est une mauvaise habitude que j'ai sur les forums, veuillez pardonner cet excès de familiarité.

En tous cas, vous avez toute ma reconnaissance, merci encore !!
 
Vote positif 0 Vote négatif

Discussions similaires

JCS32
  • Question
Microsoft 365 Surlignage des cellules comportant des doublons
Réponses
3
Affichages
113
JCS32
JCS32
W
  • Question
Microsoft 365 Fusionne les cellules vides parmi celle avec des valeurs
Réponses
4
Affichages
199
woira95
W
F
  • Résolu(e)
XL 2021 recherche doublons dans colonne puis suppression des lignes
Réponses
5
Affichages
175
ftpo69
F
Usine à gaz
  • Résolu(e)
XL 2021 Supprimer les lignes qui contiennent des cellules vides dans les colonnes "A à M" à partir de la ligne 5
Réponses
6
Affichages
254
Usine à gaz
Usine à gaz
P
  • Résolu(e)
Microsoft 365 Crée un VBA pour repérer des doublons sur un tableur excel
2 3
Réponses
31
Affichages
2 K
patrick965
P
R
  • Résolu(e)
XL 2019 supprimer lignes vides qui ont été coupées - collées
Réponses
6
Affichages
287
rh.finances
R
Y
  • Résolu(e)
XL 2016 Comment supprimer des chiffres + texte en fin de cellule
Réponses
2
Affichages
160
Yayanne76
Y
C
  • Question
Microsoft 365 Excel : regrouper des doublons sur plusieurs lignes
Réponses
7
Affichages
203
Chloé Asso
C
Z
  • Question
XL 2021 Repérer des périodes continues avec 2 critères
Réponses
8
Affichages
586
job75
job75
B
  • Question
Microsoft 365 [RESOLU] Supprimer Ligne rapidement et avec plusieurs conditions
Réponses
5
Affichages
108
BENAM69
B

Membres actuellement en ligne

4 membres et 84 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 203
Messages
2 086 196
Membres
103 153
dernier inscrit
SamirN