comparer des lignes à bases des critères

P

presdetois

XLDnaute Nouveau
Bonjour,
Je voudrais comparer plusieurs lignes d’une feuille dont les cellules contient que des numéros et supprimer les doublons sur une bases des critères voici un exemple :
1 ligne : 1.2.3.4.5.6.7.8.9.10
2 Ligne : 1.2.3.5.6.7.8
3 ligne : 1.2.3.7.8.9.11
4 ligne : 2.3.4.5.6.7.8.9.10
En comparant les quatre lignes je veux pouvoir supprimer la ligne 2 et la ligne 4 et garder les deux autres pourquoi !? Parce que les mêmes infos de ligne 2 et 4 se trouvent dans la ligne 1 et la 3 lignes est neutre.
Merci d’avance pour votre aide.
 
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : comparer des lignes à bases des critères

Re,

Voyez le fichier joint et cette macro :

Code: 
Sub Supprimer_lignes_doublons()
Dim rc&, a$(), i&, mat, s, u%, j&, t$, k%, sup As Range
With Feuil1.[C4:L7] 'CodeName de la feuille et plage à adapter
  rc = .Rows.Count
  ReDim a(1 To rc, 1 To 2) 'tableau à 2 dimensions, base 1
  '---mémorisation pour accélérer---
  For i = 1 To rc
    mat = Application.Transpose(Application.Transpose(.Rows(i)))
    a(i, 1) = " " & Trim(Join(mat)) & " "
  Next
  '---comparaison---
  For i = rc To 1 Step -1
    s = Split(a(i, 1))
    u = UBound(s) - 1
    For j = 1 To rc
      If j <> i And a(j, 2) = "" Then
        t = a(j, 1)
        For k = 1 To u
          If Not t Like "* " & s(k) & " *" Then GoTo 1
        Next
        Set sup = Union(.Rows(i), IIf(sup Is Nothing, .Rows(i), sup))
        a(i, 2) = 1 'repère
        Exit For
      End If
1   Next
  Next
  '---suppression---
  If Not sup Is Nothing Then sup.EntireRow.Delete
End With
End Sub
Il n'est pas nécessaire que sur chaque ligne les nombres soient classés.

A+
 

Pièces jointes

  • Supprimer lignes doublons(1).xls
    44 KB · Affichages: 26
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : comparer des lignes à bases des critères

Bonjour le fil, le forum,

Si les lignes à supprimer constituent un grand nombre de zones disjointes, il faut procéder autrement :

Code: 
Sub Supprimer_lignes_doublons()
Dim rc&, a$(), i&, mat, s, u%, j&, t$, k%
With Feuil1.[C4:L7] 'CodeName de la feuille et plage à adapter
  rc = .Rows.Count
  ReDim a(1 To rc, 1 To 2) 'tableau à 2 dimensions, base 1
  '---mémorisation pour accélérer---
  For i = 1 To rc
    mat = Application.Transpose(Application.Transpose(.Rows(i)))
    a(i, 1) = " " & Trim(Join(mat)) & " "
    a(i, 2) = "0"
  Next
  '---comparaison---
  For i = rc To 1 Step -1
    s = Split(a(i, 1))
    u = UBound(s) - 1
    For j = 1 To rc
      If j <> i And a(j, 2) = "0" Then
        t = a(j, 1)
        For k = 1 To u
          If Not t Like "* " & s(k) & " *" Then GoTo 1
        Next
        a(i, 2) = "#N/A" 'repère
        Exit For
      End If
1   Next
  Next
  '---suppression---
  Application.ScreenUpdating = False
  .Columns(1).Insert xlToRight 'colonne auxiliaire
  .Columns(0) = Application.Index(a, , 2)
  .EntireRow.Sort .Columns(0), xlAscending, Header:=xlNo 'tri
  On Error Resume Next 's'il n'y a pas de #N/A
  .Columns(0).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
  .Columns(0).Delete xlToLeft
End With
End Sub
Dans tous les cas c'est de toute façon plus rapide.

Fichier (2).

A+
 

Pièces jointes

  • Supprimer lignes doublons(2).xls
    50.5 KB · Affichages: 19
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : comparer des lignes à bases des critères

Re,

Concernant les durées d'exécution, testez les 2 fichiers joints (2000 lignes).

A+
 

Pièces jointes

  • Test Supprimer lignes doublons(1).xls
    144 KB · Affichages: 25
  • Test Supprimer lignes doublons(2).xls
    135 KB · Affichages: 23
Vote positif 0 Vote négatif
P

presdetois

XLDnaute Nouveau
Re : comparer des lignes à bases des critères

l’exécution est assez rapide 7 secondes pour le premier fichier et 4 seconde pour le 2 éme fichier! je dois maintenant tester le code pour voir s'il correspond bien à ce que je cherche merci beaucoup les AMIS
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : comparer des lignes à bases des critères

Re,

Voici la version (3) qui tient compte de ce que vous affirmez au post #6 :

Code: 
Sub Supprimer_lignes_doublons()
Dim rc&, a$(), i&, mat, s, j%, t$, k&
With Feuil1.[C4:L7] 'CodeName de la feuille et plage à adapter
  rc = .Rows.Count
  ReDim a(1 To rc, 1 To 2) 'tableau à 2 dimensions, base 1
  '---mémorisation pour accélérer---
  For i = 1 To rc
    mat = Application.Transpose(Application.Transpose(.Rows(i)))
    a(i, 1) = " " & Trim(Join(mat)) & " "
  Next
  '---comparaison---
  For i = rc To 1 Step -1
    a(i, 2) = "#N/A"
    s = Split(a(i, 1))
    For j = 1 To UBound(s) - 1
      t = " " & s(j) & " "
      For k = 1 To rc
        If k <> i And Len(a(k, 2)) < 2 Then _
          If InStr(a(k, 1), t) Then GoTo 1
      Next
      a(i, 2) = "0"
      Exit For
1   Next
  Next
  '---suppression---
  Application.ScreenUpdating = False
  .Columns(1).Insert xlToRight 'colonne auxiliaire
  .Columns(0) = Application.Index(a, , 2)
  .EntireRow.Sort .Columns(0), xlAscending, Header:=xlNo 'tri
  On Error Resume Next 's'il n'y a pas de #N/A
  .Columns(0).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
  .Columns(0).Delete xlToLeft
End With
End Sub
Sur le fichier Test l'exécution est bien plus rapide qu'avec la version (2).

A+
 

Pièces jointes

  • Supprimer lignes doublons(3).xls
    50.5 KB · Affichages: 23
  • Test Supprimer lignes doublons(3).xls
    144 KB · Affichages: 27
Dernière édition:
Vote positif 0 Vote négatif
P

presdetois

XLDnaute Nouveau
Re : comparer des lignes à bases des critères

Malheureusement je viens de comprendre que ce code ne marche pas comme il faut, je voulais insérer un fichier exemple mais je ne comprend pas comment le faire sur ce forum il n'y a pas un icône qui propose cette possibilité.
je fait une illustration de fichier que voici:
le code:
Option Explicit

Sub Supprimer_lignes_doublons()
Dim x#, rc&, a$(), i&, mat, s, u%, j&, t$, k%
x = Timer
With Feuil1.[A1:K27] 'CodeName de la feuille et plage à adapter
rc = .Rows.Count
ReDim a(1 To rc, 1 To 2) 'tableau à 2 dimensions, base 1
'---mémorisation pour accélérer---
For i = 1 To rc
mat = Application.Transpose(Application.Transpose(.Rows( i)))
a(i, 1) = " " & Trim(Join(mat)) & " "
a(i, 2) = "0"
Next
'---comparaison---
For i = rc To 1 Step -1
s = Split(a(i, 1))
u = UBound(s) - 1
For j = 1 To rc
If j <> i And a(j, 2) = "0" Then
t = a(j, 1)
For k = 1 To u
If Not t Like "* " & s(k) & " *" Then GoTo 1
Next
a(i, 2) = "#N/A" 'repère
Exit For
End If
1 Next
Next
'---suppression---
Application.ScreenUpdating = False
.Columns(1).Insert xlToRight 'colonne auxiliaire
.Columns(0) = Application.Index(a, , 2)
.EntireRow.Sort .Columns(0), xlAscending, Header:=xlNo 'tri
On Error Resume Next 's'il n'y a pas de #N/A
.Columns(0).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
.Columns(0).Delete xlToLeft
End With
MsgBox "Durée " & Format(Timer - x, "0.00 \s")
End Sub

les données
1 2 3 4 5 6 7 11 12 14 17
1 2 4 5 6 7 8 11 12 14 17
1 2 4 5 6 7 9 11 12 14 17
1 2 4 5 6 7 10 11 12 14 17
1 2 4 5 6 7 11 12 13 14 17
1 2 4 5 6 7 11 12 14 15 17
1 2 4 5 6 7 11 12 14 16 17
1 2 4 5 6 7 11 12 14 17 18
1 2 3 4 5 6 9 10 12 13 17
1 2 4 5 6 7 9 10 12 13 17
1 2 4 5 6 8 9 10 12 13 17
1 2 4 5 6 9 10 11 12 13 17
1 2 4 5 6 9 10 12 13 14 17
1 2 4 5 6 9 10 12 13 15 17
1 2 4 5 6 9 10 12 13 16 17
1 2 4 5 6 9 10 12 13 17 18
1 3 8 9 10 13 15 16 18
2 3 8 9 10 13 15 16 18
3 4 8 9 10 13 15 16 18
3 5 8 9 10 13 15 16 18
3 6 8 9 10 13 15 16 18
3 7 8 9 10 13 15 16 18
3 8 9 10 11 13 15 16 18
3 8 9 10 12 13 15 16 18
3 8 9 10 13 14 15 16 18
3 8 9 10 13 15 16 17 18
1 5 6 9 10
par exemple la dernière ligne devrait être supprimé!!!!
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : comparer des lignes à bases des critères

Bonjour presdetois, le forum,

presdetois à dit:
je voulais insérer un fichier exemple mais je ne comprend pas comment le faire sur ce forum il n'y a pas un icône qui propose cette possibilité.
Cliquez pour agrandir...

Cliquez sur "Aller en mode avancé" puis "Gérer les pièces jointes".

presdetois à dit:
par exemple la dernière ligne devrait être supprimé!!!!
Cliquez pour agrandir...

Elle est supprimée, et c'est même la seule, lancez la macro du fichier joint (Alt+F8).

Je pense que sur votre fichier vous n'avez pas su adapter le code :

Code: 
With Feuil1.[A1:K27] 'CodeName de la feuille et plage à adapter
C'est pourtant pas sorcier !!!

A+
 

Pièces jointes

  • Test(1).xls
    43 KB · Affichages: 22
  • Test(1).xls
    43 KB · Affichages: 21
  • Test(1).xls
    43 KB · Affichages: 20
Vote positif 0 Vote négatif

Discussions similaires

B
  • Résolu(e)
Microsoft 365 Recherche dans tableaux suivant 4 critères
2
Réponses
15
Affichages
517
Blf57
B
T
  • Question
Microsoft 365 Supprimer les lignes en doublon
2
Réponses
26
Affichages
962
Cousinhub
Cousinhub
klin89
  • Résolu(e)
Microsoft 365 Affecter des valeurs à 2 variables tableau en comparant 2 séquences d'éléments pour remplir une colonne
2 3 4
Réponses
50
Affichages
3 K
RyuAutodidacte
RyuAutodidacte
C
  • Résolu(e)
XL 2013 Insérer des lignes
Réponses
5
Affichages
352
candido57
C
N
  • Résolu(e)
XL 2021 détermination des heures de pause automatique en fonction de case vide
Réponses
10
Affichages
258
natadom
N
A
  • Résolu(e)
Microsoft 365 Correction d'un code vba
2
Réponses
22
Affichages
867
AD95
A
C
  • Question
XL 2021 Créer une vue filtrée sur plusieurs lignes
Réponses
1
Affichages
167
djidji59430
djidji59430
L
  • Résolu(e)
Microsoft 365 Cumul progressif en PowerQuery
Réponses
7
Affichages
263
oguruma
oguruma
T
  • Question
XL 2010 Supprimer les lignes en doubles (multi critères)
2
Réponses
18
Affichages
1 K
oguruma
oguruma
R
  • Résolu(e)
Autres Masquer des lignes et colonnes en fonction d'une valeur d'un menu déroulant
Réponses
1
Affichages
153
Romain77144
R

Membres actuellement en ligne

19 membres et 97 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 391
Messages
2 087 980
Membres
103 690
dernier inscrit
LeDuc