Supprimer des lignes sous conditions

[sellig 29]

Bonjour à tous,

J'aimerais pouvoir supprimer des lignes ayant des valeurs identiques dans leur intégralité. J'ai joint un fichier dans lequel je donne plus de précisions.
Merci d'avance pour votre aide 😱

 

[ROGER2327]

Re : Supprimer des lignes sous conditions

Bonsoir sellig 29

Pour la première partie de la demande (suppression de lignes), essayez ceci :

[COLOR="DarkSlateGray"][B]Sub toto()
Dim i&, j&, tmp$, oColl As New Collection
   i = 1
   Do Until IsEmpty(Cells(i, 1))
      tmp = ""
      For j = 1 To 14
         tmp = tmp & "#" & Cells(i, j).Value
      Next j
      On Error Resume Next
      oColl.Add Item:=i, Key:=tmp
      On Error GoTo 0
      i = i + 1
   Loop
   For j = 1 To oColl.Count
      Rows(oColl.Item(j)).Copy Destination:=Cells(j, 1)
   Next j
   If i <> j Then Rows(oColl.Count + 1 & ":" & i - 1).EntireRow.Delete
End Sub[/B][/COLOR]

ROGER2327
#4018

Mardi 17 Phalle 137 (Sainte Gallinacée, cocotte, SQ)
10 Fructidor An CCXVIII
2010-W34-5T20:10:07Z

 

[Robert]

Re : Supprimer des lignes sous conditions

Bonsoir Gilles, Roger, bonsoir le forum,

Certainement beaucoup plus long a s'éxécuter que la macro de Roger... Je te propose quand même le code commenté ci-dessous avec cellules en bleu si différentes :

Option Explicit 'oblige à déclarer toutes les variables
 
Sub Macro1()
Dim pl As Range 'déclare la variable pl (PLage)
Dim cel1 As Range 'déclare la variable cel1 (CELlule1)
Dim cel2 As Range 'déclare la variable cel2 (CELlule2)
Dim x As Byte 'déclare la variable x (incrément)
Dim test As Boolean 'déclare la variable test
Dim tl() As Integer 'déclare le tableau de variables tl (Tableau des Lignes)
Dim y As Integer 'déclare la variable y (incrément)
 
Set pl = Range("A1:A" & Range("A65536").End(xlUp).Row) 'définit la plage
For Each cel1 In pl 'boucle 1 : sur toutes les cellules cel1 de la plage pl
    If Not cel1.Interior.ColorIndex = 3 Then 'condition1 : si la cellule n'est pas remplie de rouge
        For Each cel2 In pl 'boucle 2 : sur toutes les cellules cel2 de la plage pl
            'condition 2 : si les adresses sont différentes et les valeurs égales
            If Not cel1.Address = cel2.Address And cel2.Value = cel1.Value Then
                For x = 1 To 14 'boucle 3 : de 1 à 14
                    'condition 3 : si une cellule de la ligne de cel1
                    'ne correspond pas avec la cellule de la ligne de cel2
                    If Cells(cel1.Row, x).Value <> Cells(cel2.Row, x).Value Then
                        Cells(cel2.Row, x).Font.ColorIndex = 5 'colore la police de la cellule cel2 de bleu
                        test = True 'définit la variable test
                    End If 'fin de la condition 3
                Next x 'prochain élément de la boucle 3
                'si test est vrai, redéfinit test à faux, va à l'étiquette "suite"
                If test = True Then test = False: GoTo suite
                cel2.Interior.ColorIndex = 3 'remplie la cellule de rouge
                ReDim Preserve tl(y) 'redimensionne le tableau tl
                tl(y) = cel2.Row 'ajoute le numéro de la ligne au tableau
                y = y + 1 'incrémente la variable y
            End If 'fin de la condition 2
suite: 'étiquette
        Next cel2 'prochaine cellule de la boucle 2
    End If 'fin de la condition 1
Next cel1 'prochaine cellule de la boucle 1
 
'boucle inversée (du dernier au premier)sur tous les éléments du tableau tl (les lignes identiques)
For y = UBound(tl) To LBound(tl) Step -1
    Rows(tl(y)).Delete 'supprime la ligne
Next y 'prochain élément du tableau
End Sub

 

[sellig 29]

Re : Supprimer des lignes sous conditions

Un grand merci à tous 2 🙂🙂🙂, les 2 macro fonctionnent parfaitement, celle de Robert étant plus complète, je vais "l'adopter", en bonus, sympa les petites explications 😉

Gilles

 

[ROGER2327]

Re : Supprimer des lignes sous conditions

Bonsoir à tous

Probablement inutile, mais, puisque je l'ai fait, je livre la procédure complétée pour le coloriage.

[COLOR="DarkSlateGray"][B]Sub toto()
Dim i&, j&, tmp$, oColl As New Collection
Dim k&, l&, n&, x, oCl() As Boolean, lCl&()
[COLOR="SeaGreen"]'Suppression des lignes doublonées.[/COLOR]
   i = 1
   Do Until IsEmpty(Cells(i, 1))
      tmp = ""
      For j = 1 To 14
         tmp = tmp & "#" & Cells(i, j).Value
      Next j
      On Error Resume Next
      oColl.Add Item:=i, Key:=tmp
      On Error GoTo 0
      i = i + 1
   Loop
   For j = 1 To oColl.Count
      Rows(oColl.Item(j)).Copy Destination:=Cells(j, 1)
   Next j
   If i <> j Then Rows(oColl.Count + 1 & ":" & i - 1).EntireRow.Delete
[COLOR="SeaGreen"]'Coloriage des items.[/COLOR]
   Set oColl = Nothing
   For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
      n = 1
      ReDim oCl(1 To 14, 1 To 1)
      ReDim lCl(1 To n)
      x = Cells(i, 1).Value
      lCl(n) = i
      For j = i + 1 To Cells(Rows.Count, 1).End(xlUp).Row
         If Cells(j, 1).Value = x Then
            n = n + 1
            ReDim Preserve lCl(1 To n)
            lCl(n) = j
            For k = 2 To 14
               oCl(k, 1) = oCl(k, 1) Or (Cells(i, k) <> Cells(j, k))
            Next k
         End If
      Next j
      For j = 1 To n
         k = lCl(j)
         On Error Resume Next
         oColl.Add Item:=k, Key:=CStr(k)
         If Err.Number = 0 Then
            On Error GoTo 0
            For l = 2 To 14
               If oCl(l, 1) Then Cells(k, l).Font.ColorIndex = 5 Else Cells(k, l).Font.ColorIndex = 0
            Next l
         End If
      Next j
   Next i
End Sub[/B][/COLOR]

ROGER2327
#4019

Mercredi 18 Phalle 137 (Lingam, SQ)
11 Fructidor An CCXVIII
2010-W34-6T22:41:44Z

 

[david84]

Re : Supprimer des lignes sous conditions

Bonjour sellig 29, Robert, Roger,
Roger, auriez-vous l'amabilité de m'expliquer votre macro ?
J'arrive à comprendre celle de Robert grâce à ses commentaires, mais pas la vôtre.
Merci.
David

 

[sellig 29]

Re : Supprimer des lignes sous conditions

Merci Roger pour votre perspicacité et votre talent!

 

[ROGER2327]

Re : Supprimer des lignes sous conditions

Re...

Bonjour sellig 29, Robert, Roger,
Roger, auriez-vous l'amabilité de m'expliquer votre macro ?
J'arrive à comprendre celle de Robert grâce à ses commentaires, mais pas la vôtre.
Merci.
David

La procédure proposée plus haut est effectivement assez complexe, mais je n'en rédigerai pas le commentaire, pour deux raisons :

1. C'est long à faire, et je n'ai pas le temps en ce moment.
2. Et surtout, c'est inutile car elle est inutilement compliquée.

Je préfère en donner une autre, plus simple et plus efficace :

[COLOR="DarkSlateGray"][B]Sub toto()
Dim i&, j&, k&, l&, x, tmp$, par(1 To 3), oColl As New Collection
[COLOR="SeaGreen"]'
'Optimisation de l'environnement.[/COLOR]
   With Application
      par(1) = .EnableEvents: par(2) = .Calculation: par(3) = .ScreenUpdating
      .ScreenUpdating = False: .Calculation = xlCalculationManual: .EnableEvents = False
   End With
[COLOR="SeaGreen"]'
'Suppression des lignes doublonées.[/COLOR]
   i = 1
   Do Until IsEmpty(Cells(i, 1))
      tmp = ""
      For j = 1 To 14
         tmp = tmp & "#" & Cells(i, j).Value
      Next
      On Error Resume Next
      oColl.Add Item:=i, Key:=tmp
      If Err.Number Then Rows(i).Delete Else i = i + 1
      On Error GoTo 0
   Loop
   Set oColl = Nothing
[COLOR="SeaGreen"]'
'Coloriage des items.[/COLOR]
   With Cells(Rows.Count, 1).End(xlUp)
      Range(Cells(1, 1), .Offset(0, 13)).Font.ColorIndex = 0
      l = .Row
   End With
   For i = 1 To l - 1
      x = Cells(i, 1).Value
      For j = i + 1 To l
         If Cells(j, 1).Value = x Then
            For k = 2 To 14
               If Cells(i, k).Value <> Cells(j, k).Value Then Union(Cells(i, k), Cells(j, k)).Font.ColorIndex = 5
            Next
         End If
      Next
   Next
[COLOR="SeaGreen"]'
'Restauration de l'environnement.[/COLOR]
   With Application
      .EnableEvents = par(1): .Calculation = par(2): .ScreenUpdating = par(3)
   End With
End Sub[/B][/COLOR]

Celle-ci est, je crois, beaucoup plus claire. Si toutefois elle pose des problèmes de compréhension, je prendrai le temps d'un écrire un commentaire.
Je profite de ce message pour attirer l'attention de sellig 29 sur le fait que cette procédure (comme la première que j'ai proposée) ne donne pas toujours le même résultat que celle de Robert (que je salue au passage...) : il arrive parfois que certains doublons sont conservés par la procédure de Robert sans que j'ai pu en trouver la raison. Une étude serrée du problème reste à faire...​

ROGER2327
#4029

Vendredi 20 Phalle 137 (Pie VIII, navigant, SQ)
13 Fructidor An CCXVIII
2010-W35-1T21:56:28Z