VBA Suppression des lignes en double avec conditions
Bonjour,
Sur un fichier Excel j'ai une multitude des lignes en doubles à supprimer mais avec des conditions.
La principale règle est de supprimer les doublons pour les mêmes lignes qui ont la même valeur de la colonne A (SOURCE), c à d si comme si on travaille sur un bloc spécifique de lignes tout en respectant les conditions suivantes en ordre de priorité lors de la suppression :
* Données de la colonne E (Données 4) si existe.
* Données de la colonne B (Données 1) si existe.
* Données de la colonne C (Données 2) si existe.
* Données de la colonne D (Données 3) si existe.
* Données de la colonne F (Données 5) si existe.
Pour mieux expliquer, sur 2 lignes qui se suivent et qui ont la même valeur de la colonne A (SOURCE) je dois garder la ligne qui contient le maximum des cellules renseignées tout en respectant les conditions ci-dessus.
J'ai utilisé ce code ci-dessous mais qui n'est pas complet ou/et incorrect :
Sub Supp_doublons()
Dim lg As Long
Sheets("Données").Activate
For lg = 2 To 100
If Cells(lg, 1) = Cells(lg + 1, 1) Then
If Cells(lg, 5) = Cells(lg + 1, 5) And Cells(lg, 2) = Cells(lg + 1, 2) And Cells(lg, 4) = Cells(lg + 1, 4) Then
Rows(lg + 1).Delete
End If
End If
Next lg
End SubMerci par avance pour votre réponse.
Bonjour,
A tester :
Option Explicit
Sub SupprimerLesDoublons()
Dim LigneTrouvee As Boolean
Dim I As Long, IndexMatrice As Long, DerniereLigne As Long, LigneAlpha As Long
Dim MonDico As Object
Dim PoidsAlpha As String, PoidsEnCours As String
Dim Matrice() As Variant
Dim ShSource As Worksheet
On Error GoTo Fin
Application.ScreenUpdating = False
Set MonDico = CreateObject("Scripting.Dictionary")
Set ShSource = ActiveSheet
With ShSource
DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
IndexMatrice = 0
'.Columns("7,9").Cells.Clear ' pour vérifier
' Ajout des données de la colonne A sans doublons dans le Dico
'-------------------------------------------------------------
For I = 2 To DerniereLigne
If .Cells(I, 1) <> "" Then
If Not MonDico.Exists(UCase(.Cells(I, 1).Value)) Then
MonDico.Add (UCase(.Cells(I, 1).Value)), CStr(UCase(.Cells(I, 1).Value))
ReDim Preserve Matrice(2, IndexMatrice)
Matrice(0, IndexMatrice) = .Cells(I, 1)
IndexMatrice = IndexMatrice + 1
End If
End If
Next I
' Evaluation du poids de chaque ligne
'------------------------------------
For IndexMatrice = LBound(Matrice, 2) To UBound(Matrice, 2)
PoidsAlpha = ""
PoidsEnCours = ""
LigneAlpha = 0
For I = 1 To DerniereLigne
If Matrice(0, IndexMatrice) = .Cells(I, 1) Then
If .Cells(I, 5) <> "" Then
PoidsEnCours = "1"
Else
PoidsEnCours = "0"
End If
If .Cells(I, 2) <> "" Then
PoidsEnCours = PoidsEnCours & "1"
Else
PoidsEnCours = PoidsEnCours & "0"
End If
If .Cells(I, 3) <> "" Then
PoidsEnCours = PoidsEnCours & "1"
Else
PoidsEnCours = PoidsEnCours & "0"
End If
If .Cells(I, 4) <> "" Then
PoidsEnCours = PoidsEnCours & "1"
Else
PoidsEnCours = PoidsEnCours & "0"
End If
If .Cells(I, 6) <> "" Then
PoidsEnCours = PoidsEnCours & "1"
Else
PoidsEnCours = PoidsEnCours & "0"
End If
End If
If Val(PoidsEnCours) > Val(PoidsAlpha) Then
PoidsAlpha = PoidsEnCours
LigneAlpha = I
End If
Next I
Matrice(1, IndexMatrice) = PoidsAlpha
Matrice(2, IndexMatrice) = LigneAlpha
Next IndexMatrice
'Pour vérifier sur les colonnes G à I
'------------------------------------
' For IndexMatrice = LBound(Matrice, 2) To UBound(Matrice, 2)
' .Cells(Matrice(2, IndexMatrice), 7) = Matrice(0, IndexMatrice)
' .Cells(Matrice(2, IndexMatrice), 8) = Matrice(1, IndexMatrice)
' .Cells(Matrice(2, IndexMatrice), 9) = Matrice(2, IndexMatrice)
' Next IndexMatrice
' Suppression des lignes
'-----------------------
For I = DerniereLigne To 2 Step -1
LigneTrouvee = False
For IndexMatrice = UBound(Matrice, 2) To LBound(Matrice, 2) Step -1
If I = Matrice(2, IndexMatrice) Then
LigneTrouvee = True
Exit For
End If
Next IndexMatrice
If LigneTrouvee = False Then
' .Cells(I, 7).Interior.Color = RGB(255, 255, 0) ' Pour vérifier les lignes à supprimer
.Cells(I, 1).EntireRow.Delete
End If
Next I
End With
MsgBox "Fin de traitement !", vbInformation, "Supprimer les lignes en doublon"
GoTo Fin
Fin:
Application.ScreenUpdating = True
Set ShSource = Nothing
Set MonDico = Nothing
End SubBonjour,
Je vous remercie pour votre réponse.
J'ai testé mais il me supprime toutes lignes, même celles pour données différentes sur autres cellules de la même ligne, ile ne me garde qu'une seule ligne de chaque valeur Source.
Ci-joint mon fichier Excel.
Sur la feuille "Données" le résultat de votre code.
Sur feuille "Save _Données" ce sont les lignes que j'avais au début, il doit me supprimer normalement ceux en couleur rouge ( lignes : 2 / 3 / 5 / 7 / 15 / 23).
A savoir que j'ai effectué un filtre personnalisé avant de lancer votre macro.
* Données de la colonne A (SOURCE) du Plus petit au Plus grand.
* Données de la colonne E (Données 4) de A à Z.
* Données de la colonne B (Données 1) du Plus petit au Plus grand.
* Données de la colonne C (Données 2) de A à Z.
* Données de la colonne D (Données 3) de A à Z.
* Données de la colonne F (Données 5) de A à Z.
Je vous remercie une autre fois.
Le code correspond à l'énoncé de votre premier message et fonctionne correctement.
Dans votre dernier message, vous indiquez qu'il faut tenir compte de l'emplacement dans le tableau et prendre la dernière ligne si situation identique. Cela ne correspond plus à ce qui était demandé au départ.
Je m'excuse si je n'ai pas bien pu m'exprimer pour le souci rencontré, c'est un peu difficile vu les données des cellules pour chaque ligne.
Maintenant j'ai pu me débrouiller avec la suppression des doublons en jouant sur les colonnes.
SVP avec le code ci-dessous, comment pouvoir supprimer la ligne dont la cellule de la colonne 2 est vide et garder la ligne dont la cellule de la colonne 2 est renseignée.
Sub Supp_doublons()
Dim lg As Long
Sheets("Données").Activate
For lg = 2 To 1000
If Cells(lg, 1) = Cells(lg + 1, 1) And Cells(lg, 5) = Cells(lg + 1, 5) And Cells(lg, 4) = Cells(lg + 1, 4) And (Cells(lg, 2) = "" Or Cells(lg + 1, 2) = "") Then
' Code pour comment pouvoir supprimer la ligne dont la cellule de la colonne 2 est vide et garder la ligne dont la cellule de la colonne 2 est renseignée. ???
End If
Next lg
End SubMerci pour votre réponse.
Dans votre exemple, les cas = 1 dans la colonne A sont tous vides en colonne B. Que faut-il comprendre ?
Il faut supprimer la ligne 7 ou 8, mais de préférence la ligne 7 puisque Cells(7, F) est vide.
Le but en fait, c'est de supprimer les lignes en double pour même valeur de colonne A tout en prenant en compte que si différence entre 2 lignes pour cellules existantes et autres non existante on garde la ligne de celles existantes.
Donc sur mon fichier si vous filtrez avec les valeurs de la colonne A, vous allez voir les lignes qu'il doivent normalement être supprimées et qui sont en rouge.
Par exemple entre la ligne 22 et 23 à garder la ligne 22 puisque Cells(23, B) est vide.
Pour cette raison j'ai demandé le complément de mon code ci-dessous qui sert par exemple pour le cas des lignes 22 et 23.
Je vous remercie.
Sub Supp_doublons()
Dim lg As Long
Sheets("Données").Activate
For lg = 2 To 1000
If Cells(lg, 1) = Cells(lg + 1, 1) And Cells(lg, 5) = Cells(lg + 1, 5) And Cells(lg, 4) = Cells(lg + 1, 4) And (Cells(lg, 2) = "" Or Cells(lg + 1, 2) = "") Then
' Code pour comment pouvoir supprimer la ligne dont la cellule de la colonne 2 est vide et garder la ligne dont la cellule de la colonne 2 est renseignée. ???
End If
Next lg
End SubVotre dernière réponse n'est pas cohérente avec ce que vous avez expliqué plus haut (ou plutôt ce qu'on pouvait en déduire). C'est la ligne 8 qu'il faut garder.
Voici un code qui correspond plus à ce que j'ai compris :
Option Explicit
Sub SupprimerLesDoublons()
Dim LigneTrouvee As Boolean
Dim I As Long, IndexMatrice As Long, DerniereLigne As Long, LigneAlpha As Long, Poids As Long
Dim MonDico As Object
Dim PoidsAlpha As String, PoidsEnCours As String
Dim Matrice() As Variant
Dim ShSource As Worksheet
On Error GoTo Fin
Application.ScreenUpdating = False
Set MonDico = CreateObject("Scripting.Dictionary")
Set ShSource = Sheets("Save Données (2)")
With ShSource
DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
IndexMatrice = 0
.Columns("7,9").Cells.Clear
' Ajout des données de la colonne A sans doublons dans le Dico
'-------------------------------------------------------------
For I = 2 To DerniereLigne
.Cells(I, 8) = PoidsLigne(ShSource, I)
If .Cells(I, 1) <> "" Then
If Not MonDico.Exists(UCase(.Cells(I, 1).Value)) Then
MonDico.Add CStr(.Cells(I, 1).Value), CStr(.Cells(I, 1).Value)
ReDim Preserve Matrice(2, IndexMatrice)
Matrice(0, IndexMatrice) = CStr(.Cells(I, 1))
IndexMatrice = IndexMatrice + 1
End If
End If
Next I
For IndexMatrice = LBound(Matrice, 2) To UBound(Matrice, 2)
PoidsAlpha = ""
PoidsEnCours = ""
LigneAlpha = 0
Poids = 0
For I = 1 To DerniereLigne
If CStr(.Cells(I, 1)) = CStr(Matrice(0, IndexMatrice)) Then
If Val(.Cells(I, 8)) >= Poids Then
Poids = Val(.Cells(I, 8))
LigneAlpha = I
End If
End If
Next I
Matrice(1, IndexMatrice) = Poids
Matrice(2, IndexMatrice) = LigneAlpha
For I = 1 To DerniereLigne
If CStr(.Cells(I, 1)) = CStr(Matrice(0, IndexMatrice)) Then
If I <> LigneAlpha Then .Cells(I, 1).EntireRow.Clear
End If
Next I
Next IndexMatrice
End With
TrierLeTableau ShSource
MsgBox "Fin de traitement !", vbInformation, "Supprimer les lignes en doublon"
GoTo Fin
Fin:
Application.ScreenUpdating = True
Set ShSource = Nothing
Set MonDico = Nothing
End Sub
Function PoidsLigne(ByVal ShDonnees As Worksheet, ByVal LigneEnCours As Long) As Integer
Dim PoidsEnCours As String
With ShDonnees
PoidsEnCours = ""
If .Cells(LigneEnCours, 5) <> "" Then
PoidsEnCours = "1"
Else
PoidsEnCours = "0"
End If
If .Cells(LigneEnCours, 2) <> "" Then
PoidsEnCours = PoidsEnCours & "1"
Else
PoidsEnCours = PoidsEnCours & "0"
End If
If .Cells(LigneEnCours, 3) <> "" Then
PoidsEnCours = PoidsEnCours & "1"
Else
PoidsEnCours = PoidsEnCours & "0"
End If
If .Cells(LigneEnCours, 4) <> "" Then
PoidsEnCours = PoidsEnCours & "1"
Else
PoidsEnCours = PoidsEnCours & "0"
End If
If .Cells(LigneEnCours, 6) <> "" Then
PoidsEnCours = PoidsEnCours & "1"
Else
PoidsEnCours = PoidsEnCours & "0"
End If
End With
PoidsLigne = Val(PoidsEnCours)
End Function
Sub TrierLeTableau(ByVal Sh As Worksheet)
With Sh
.Columns("A:H").Select
.Sort.SortFields.Clear
.Sort.SortFields.Add2 Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A:H")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End SubMerci infiniment pour votre réponse.
Mais le but voulu n'est pas encore atteint, en exécutant votre code il me laisse seulement une ligne pour chaque valeur de la colonne A, soit 7 lignes.
Or si j'élimine pour le même fichier les lignes manuellement (selon mo besoin ce sont les lignes en rouge qui doivent êtres supprimés) je dois avoir ceci, soit 16 lignes :
Pour faciliter les choses, je vous explique brièvement pourquoi la(es) ligne(s) X doit(vent) être(s) supprimée(s) :
* Pour les lignes de 2 à 5 avec valeur identique "0" au niveau de la colonne A : la ligne 4 à garder seule puisque identique avec 2 et 3 et 5 mais la cellule(5, F) est vide.
* Pour les lignes de 6 à 8 avec valeur identique "1" au niveau de la colonne A : la ligne 6 à garder puisque différente de 7 et 8. Puis 7 à supprimer puisque la cellule(7, F) est vide.
* Pour les lignes de 9 à 10 avec valeur identique "3" au niveau de la colonne A : les 2 lignes à garder puisque la cellule(9, B) et la cellule(10, B) sont différentes.
* Pour les lignes de 11 à 14 avec valeur identique "5" au niveau de la colonne A : les 4 lignes à garder puisque les données des cellules de la colonne D sont différentes et aussi les données des cellules de la colonne E sont différentes.
* Pour les lignes de 15 à 18 avec valeur identique "7" au niveau de la colonne A : la ligne 15 ou la ligne 16 à garder puisque les données de la ligne 15 et la ligne 16 sont identiques sauf pour donnée cellule(15, F) et donnée cellule(16, F) qui existante mais non identique, d'où on garde la ligne 15 ou ligne 16. A noter que on garde aussi les lignes 17 et 18 puisque puisque les données des cellules de la colonne D sont différentes et aussi les données des cellules de la colonne E sont différentes.
* Pour les lignes de 19 à 21 avec valeur identique "9" au niveau de la colonne A : les 3 lignes à garder puisque les données des cellules de la colonne D sont différentes et aussi les données des cellules de la colonne E sont différentes.
* Pour les lignes de 22 à 23 avec valeur identique "11" au niveau de la colonne A : la ligne 22 à garder seule puisque cellule(23, B) est vide et les données des cellules de la colonne D sont différentes et aussi les données des cellules de la colonne E sont identique.
Ci-joint le fichier avec feuille "Données" souhaitée à avoir et la feuille "Save Données" qui est l'originale pour tester.
Merci par avance pour votre retour.
Je n'ai pas pu télécharger le fichier Excel hier.
Ci-joint le fichier "Test-Forum.xlsx" avec feuille "Données" souhaitée à avoir et la feuille "Save Données" qui est l'originale pour tester SVP.
Merci par avance pour votre retour et votre collaboration.