XL 2021 Doublons

JohnBill

XLDnaute Occasionnel
Bonjour à tout le forum et joyeux lundi de Pâques à tous.
J'ai un souci d'affichage que je n'arrive pas à comprendre.
J'ai créé un fichier pour exemple avec une macro trouvée sur Youtube qui fonctionne parfaitement dans la vidéo mais, dans mon fichier, chez moi, cela ne fonctionne pas
Cette macro est censée colorer les lignes en doublon mais elles restent de la même couleur et, lorsque je vais dans le menu format de cellule, elle est bien rouge.
Est ce que cela viendrai du fait que je suis en mode sombre d'excel ?
Ci-joint mon fichier et merci d'avance pour une solution.
 

Pièces jointes

  • Supprimer_doublons_vba.xlsm
    22.9 KB · Affichages: 15

chris

XLDnaute Barbatruc
Bonjour
Pourquoi une macro ?
Une simple MFC suffit
1711972536958.png
 

JohnBill

XLDnaute Occasionnel
Je connais la MFC mais comme j'ai un assez grand nombre d'onglets, une macro sera plus rapide à faire.
Quand au post en double je l'ai fait car mon premier n'apparaissait pas dans la liste sur le site? J'ao=i cru que j'avais foiré.
Merci de vos réponses
 

JohnBill

XLDnaute Occasionnel
fanch55 me dit qu'il y a un nombre de MFC inutiles c'est parce que lorsque je l'ai ait fait le résultat n'apparaissait pas comme indiqué dans ma demande. Le but de ma demande était uniquement sur le fait que ces MFC ne se réalisaient pas (Les lignes ne se colorent pas).
 

laurent950

XLDnaute Barbatruc
Bonsoir @JohnBill

Effacer le format au début, Les MCF et les Intérieurs couleurs (A régler) selon vos besoin.
Le Code : Doublons Multichoix


VB:
Sub SupprimerMFC_Puis_GestionDoublons()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        With ws.Cells
        ' Suppression des mises en forme conditionnelle sur toute la feuille
            .FormatConditions.Delete
        ' Suppression des mises en forme Intérieur couleur Cellule sur toute la feuille
            .Interior.Pattern = xlNone
            .Interior.TintAndShade = 0
            .Interior.PatternTintAndShade = 0
        End With
    Next ws

    ' Appel de la macro GestionDoublons
    GestionDoublons
End Sub
Sub GestionDoublons()
    Dim choix As Variant
    Dim choix2 As String
    Dim der_ligne As Long
    Dim tab_cells() As Variant
    Dim ligne As Long
    Dim contenu As Variant
    Dim i As Long
    Dim nb As Long
    Dim compteur As Long
    Dim test As Double
    Dim res_test As String

    choix = InputBox("Avant d'utiliser cet outil, n'oubliez pas d'enregistrer votre fichier !" & Chr(10) & Chr(10) & _
                     "Choisissez l'action qui vous intéresse :" & Chr(10) & Chr(10) & _
                     "1. Colorer les doublons (colorer la cellule)" & Chr(10) & _
                     "2. Colorer les doublons (colorer la ligne entière)" & Chr(10) & _
                     "3. Effacer les doublons (en laissant la ligne vide)" & Chr(10) & _
                     "4. Supprimer les doublons (ligne entière)" & Chr(10) & _
                     "5. Supprimer les lignes vides" & Chr(10) & Chr(10) & _
                     "Entrez le n° de l'action et cliquez sur OK :", _
                     "Gestion des doublons")

    If choix = "" Then Exit Sub

    choix2 = InputBox("Entrez la lettre de la colonne où les doublons doivent être recherchés :", "Gestion des doublons")
    If choix2 = "" Then Exit Sub

    Application.ScreenUpdating = False
    test = Timer
    der_ligne = Range(choix2 & Rows.Count).End(xlUp).Row

    ReDim tab_cells(1 To der_ligne)
    For ligne = 1 To der_ligne
        tab_cells(ligne) = Range(choix2 & ligne).Value
    Next ligne
    nb = 0
    compteur = 0

    For ligne = 1 To der_ligne
        contenu = tab_cells(ligne)

        If (choix = 1 Or choix = 2) And contenu <> "" Then 'Colorer doublons
            For i = 1 To der_ligne
                If contenu = tab_cells(i) And ligne <> i Then 'Si doublon
                    nb = nb + 1
                    If choix = 1 Then
                        Range(choix2 & ligne).Interior.ColorIndex = 3
                    Else
                        Rows(ligne).Interior.ColorIndex = 3
                    End If
                    Exit For
                End If
            Next i
        End If

        If (choix = 3 Or choix = 4) And ligne > 1 And contenu <> "" Then 'Effacer/supprimer doublons
            For i = 1 To ligne - 1
                If contenu = tab_cells(i) Then 'Si doublon
                    nb = nb + 1
                    If choix = 3 Then
                        Rows(ligne).ClearContents
                    Else
                        Rows(ligne + compteur).Delete
                        compteur = compteur - 1
                    End If
                    Exit For
                End If
            Next i
        End If

        If choix = 5 And contenu = "" Then 'Lignes vides
            Rows(ligne + compteur).Delete
            compteur = compteur - 1
            nb = nb + 1
        End If
    Next ligne

    res_test = Format(Timer - test, "0" & Application.DecimalSeparator & "000")
    Application.ScreenUpdating = True

    Select Case choix
        Case 5
            If nb = 0 Then
                MsgBox "Aucune ligne vide trouvée ..."
            Else
                MsgBox nb & " lignes supprimées (en " & res_test & " secondes)"
            End If
        Case 4
            MsgBox nb & " doublons supprimés (en " & res_test & " secondes)"
        Case 3
            MsgBox nb & " doublons effacés (en " & res_test & " secondes)"
        Case Else
            If nb = 0 Then
                MsgBox "Aucun doublon trouvé dans la colonnne " & UCase(choix2) & " ..."
            Else
                MsgBox nb & " doublons passés en rouge (en " & res_test & " secondes)"
            End If
    End Select
End Sub
 

JohnBill

XLDnaute Occasionnel
Bonjour Laurent950.
J'ai copié votre macro dans le fichier test créé pour l'occasion, j'ai lancé la macro et un message m'informe que 991 doublons ont été trouvés (Ce qui me parait beaucoup. Il n'y en a pas tant) mais, comme vous pouvez le voir dans ce même fichier joint qu'aucune ligne n'a changé de couleur.
De plus j'ai quelquefois des doublons colonne C mais qui n'en sont pas vraiment car il y a un différence dans la colonne B (Même nom d'album pour un artiste différent). Il faudrait faire le tri sur deux colonnes (B et C).
Merci d'avance pour tout votre travail.
 

Pièces jointes

  • TestDoublons.xlsm
    382 KB · Affichages: 9

JohnBill

XLDnaute Occasionnel
Rebonjour laurent950.
Une info importante : je viens d'enlever le mode sombre de windows et bien sur, Excel est redevenu sur fond blanc. J'ai relancé ta macro et elle a fonctionné. Conclusion : c'est bien le mode sombre qui empêche la coloration des cellules. Mais comment y rémédier ? Là est la question.
 

JohnBill

XLDnaute Occasionnel
Puisque cette macro fonctionne, je désactiverais le mode sombre pour l'utiliser mais j'ai une autre question qui fait suite à ma première utilisation de celle ci.
Quelquefois, pour un même titre je peux avoir un classement différent ou un artiste différent. Est il possible de trouver les doublons par rapport à toutes les colonnes et pas seulement la colonne C ?
 

Cousinhub

XLDnaute Barbatruc
Inactif
Bonsoir,
Une autre option, qui te donne le nombre d’occurrences selon Auteur et Nom (mais on peut adapter), et qui donne également les lignes où se situent les doublons, triplons et quadruplons.
Pour adapter la recherche de doublons, il suffit de mettre un "x" dans la colonne B de l'onglet "Paramètres" en face du nom de l'en-tête de colonne du Tableau de l'onglet "Données"
Pour ce faire, j'utilise Power Query en natif dans ta version Excel. (Donc, pas de macros) - Un simple "Actualiser tout" du ruban "Données" suffit pour mettre à jour
Si ça t'intéresse...
Edit, fichier modifié, et mis ci-dessous
 
Dernière édition:

laurent950

XLDnaute Barbatruc
Bonsoir @JohnBill

Le Poste #8 répond au Poste #1, ce qui signifie que la procédure VBA correspond à ce que vous avez décrit.

@JohnBill = "Parfois, pour un même titre, je peux obtenir un classement différent ou un artiste différent. Est-il possible de trouver les doublons par rapport à toutes les colonnes et pas seulement à la colonne C ?"

Je vous propose de me fournir un exemple de doublons à trouver sur votre fichier dans le Poste #9, en spécifiant les colonnes et les doublons.

Une fois que j'aurai ces informations, je pourrai rédiger le code approprié.
 

fanch55

XLDnaute Barbatruc
Une autre proposition moins riche mais qui fait le demandé :
Dblsup à exécuter:
VB:
Sub DblSup()
Dim Sht As Worksheet, Plage As Range, Choix, Col, I As Integer
Const Color = 6740479 ' <- couleur des doublons
    For Each Sht In Worksheets ' Pour chaque feuille
        Sht.Activate
        Sht.AutoFilterMode = False ' On neutralise le filtrage existant
        lc = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        lr = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set Plage = Range("A2", Cells(lr, lc)) ' Définition de la plage à traiter
        Choix = InputBox("Feuille " & Sht.Name & vbLf & "Indiquer la plage à traiter", "Doublons???", Plage.Address)
        If Choix <> "" Then
           ' préparation de la feuille
            Cells.FormatConditions.Delete
            Cells.Interior.Pattern = xlNone
           ' on formate la colonne 1 en string
            Plage.Columns(1).NumberFormat = "@"
            For Each Cel In Plage.Columns(1).Cells
                Cel.Value = Format(Cel.Value, "0000")
            Next
            Set Plage = Range(Choix)
            Tri_Données Plage
            With Plage.FormatConditions.Add(Type:=xlExpression, _
                Formula1:="=Dblon(" & Plage.Rows(1).Address(False) & ")")
                .Interior.Color = Color
                .StopIfTrue = Faux
            End With
            d1 = Plage.Rows.Count
           ' on filtre les données pour ne montrer que les doublons
            Range("A1", Cells(lr, lc)).AutoFilter Field:=1, Criteria1:=Color, Operator:=xlFilterCellColor
            On Error Resume Next
            d2 = Plage.SpecialCells(xlCellTypeVisible).Rows.Count
            If d2 > 0 Then
                ReDim Col(Plage.Columns.Count - 1): For I = 0 To UBound(Col): Col(I) = I + 1: Next
                If MsgBox("Les lignes identiques vont être fusionnées", vbCritical + vbOKCancel) = vbOK _
                Then Plage.RemoveDuplicates (Col)
                Sht.AutoFilterMode = False
                lr = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                d2 = Range("A2", Cells(lr, lc)).Rows.Count
                MsgBox d1 - d2 & " lignes ont été supprimées", vbInformation
            Else
                MsgBox "Aucun doublon trouvé"
                Sht.AutoFilterMode = False
            End If
        End If
    Next
End Sub
Sub Tri_Données(Plage As Range)
Dim Cel As Range
   ' on trie les données dans l'ordre des colonnes comme elles sont
    With ActiveSheet.Sort
        .SortFields.Clear
        For I = 2 To Plage.Columns.Count
            .SortFields.Add2 Key:=Plage.Columns(I), SortOn:=xlSortOnValues, Order:=xlAscending   ' xlSortTextAsNumbers
        Next
        .SortFields.Add2 Key:=Plage.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        .SetRange Plage
        .Header = xlYes: .MatchCase = False
        .Orientation = xlTopToBottom: .SortMethod = xlPinYin
        .Apply
    End With

End Sub
Function Dblon(Plage As Range) As Boolean
Dim Cel As Range, V As Integer
    V = 0: For Each Cel In Plage ' comparaison avec la ligne du dessus
        If Cel = Cel.Offset(-1) _
        Then V = V + 1 Else Exit For
    Next
    If V = Plage.Count Then Dblon = True: Exit Function
    V = 0: For Each Cel In Plage ' comparaison avec la ligne du dessous
        If Cel = Cel.Offset(1) _
        Then V = V + 1 Else Exit For
    Next
    If V = Plage.Count Then Dblon = True: Exit Function
    Dblon = False
End Function
 

Discussions similaires

Statistiques des forums

Discussions
313 309
Messages
2 097 033
Membres
106 812
dernier inscrit
Excellou74