Supprimer les doublons dans un tableau?

[alol.ita]

Bonjour,

A la fin de ma macro, j'ai un tableau de données où existe des doublons (ou qui apparaissent même plusieurs fois).
Les données sont réparties sur 5 Colonnes
Si les données sur les Colonnes A,B,D,E sont identiques...j'aimerais pour terminer ma macro supprimer ces doublons en supprimant la ligne.
Je joins un extrait du tableau (les doublons sont repérés en couleur)
Merci pour votre aide!
[file name=RechDoublons.zip size=5729]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/RechDoublons.zip[/file]

 

[Flyonets]

Bonjour
ci joint un fichier d'un celebre mvp
Bon courage [file name=doublons_20051102060633.zip size=15857]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/doublons_20051102060633.zip[/file]

 

[alol.ita]

Merci Flyonets pour ta réponse rapide!
Mais je viens de tester cette macro sur les doublons en Col A ,B et D...ça ne marche pas...j'ai une erreur!!!
J'ai un X= Erreur 2029 et ensuite donc 'Incompatibilité de Type'
Je ne vois pas où est le problème???
Je l'ai mis en fichier joint!

:unsure: [file name=RechDoublons2.zip size=8580]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/RechDoublons2.zip[/file]

 

[myDearFriend!]

Bonsoir alol.ita, Flyonets,

Tu peux également, si tu le souhaites, essayer la macro complémentaire que j'avais faite justement pour ça.

Ci-joint la version 3.2 de cet utilitaire pour détecter, supprimer et/ou archiver les doublons (multicolonnes) de ton fichier :

Après avoir lancé ce fichier, un nouveau bouton 'Doublons' apparaît dans ta barre d'outils Excel. Tu cliques dessus.
Dans la liste des colonnes qui s'affiche, tu sélectionnes A, B, D et E, tu coches ensuite 'Archivage doublons' (si tu souhaites en garder une trace), puis tu valides par le bouton 'Supprimer Doublons'.


Pour les utilisations futures, tu auras 2 façons de faire à ta disposition :

1) La première est de lancer le fichier ponctuellement, tu l'ouvriras donc dans Excel (comme n'importe quel classeur 'classique') lorque tu en auras besoin.

2) La deuxième consiste à le faire charger automatiquement à chaque démarrage d'Excel pour l'avoir ainsi tout le temps à disposition :
- Tu enregistres ce fichier '.xla' dans ton répertoire de Macros Complémentaires
- Tu lances Excel, puis tu fais Outils/Macros Complémentaires
- Tu coches 'mDF_Doublons', puis OK.

Dans les 2 cas, un nouveau bouton intitulé 'Doublons' apparaît maintenant dans la barre d'outils Excel. Un clic dessus et le traitement de la feuille active peut commencer...


Cordialement,

[file name=mDF_Doublons32.zip size=18143]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/mDF_Doublons32.zip[/file]

 

[alol.ita]

J'ai testé cette macro complémentaire qui fonctionne bien pour mon cas...mais j'aimerais l'inclure dans ma macro...et je ne sais pas comment faire...
Par contre j'ai trouvé sur le site de frederic.sigonneau
Ce site n'existe plus
une macro qui convient bien à mon cas de doublons sur plusieurs colonnes
'Recherche de doublons multi-colonnes avec correspondance multi-critères'...mais en fait j'aimerais supprimer les lignes des doublons
et non les archiver sur une feuille.
Merci

Dim CheckRows As Range
Dim ColumnsToMatch As Variant
Dim DeleteDuplicates As Boolean
Dim FormatDuplicates As Boolean
Dim WriteListOfDuplicates As Boolean
Dim AddRowNumberToList As Boolean
Dim lLBound As Long
Dim lUBound As Long
Dim CheckRange As Range
Dim SubArray As Variant
Dim FieldsCollection As New Collection
Dim RowNumberCollection As New Collection
Dim Dummy As Long
Dim DuplicateRange As Range
Dim DuplicatesExist As Boolean
Dim lRow As Long
Dim CollectionKey As String
Dim OffsetValue() As Long
Dim StartCell As Range
Dim Element As Variant
Dim Counter As Long

    'adapter les 6 variables ci-dessous pour mettre à jour
    'les paramètres de travail de la macro
    Set CheckRows = Rows('1:1000')
    ColumnsToMatch = Array('A', 'B', 'C')
    DeleteDuplicates = False
    FormatDuplicates = False
    WriteListOfDuplicates = True
    AddRowNumberToList = True


    lLBound = LBound(ColumnsToMatch)
    lUBound = UBound(ColumnsToMatch)

    Set CheckRange = Intersect(Range(ColumnsToMatch(lLBound) & _
        ':' & ColumnsToMatch(lLBound)), CheckRows)

    ReDim OffsetValue(lUBound - lLBound + 1)

    For Counter = lLBound To lUBound
        OffsetValue(Counter) = Range(ColumnsToMatch(Counter) & ':' & _
            ColumnsToMatch(Counter)).Column - CheckRange.Column
    Next Counter

    On Error Resume Next
    SubArray = CheckRange.Value
    For lRow = 1 To UBound(SubArray, 1)
        If SubArray(lRow, 1) <> '' Then
            CollectionKey = ''
            For Counter = lLBound To lUBound
                CollectionKey = CollectionKey & _
                    CheckRange(lRow, 1).Offset(0, _
                    OffsetValue(Counter)).Value
            Next Counter
            FieldsCollection.Add Dummy, CStr(CollectionKey)
            If Err.Number = 457 Then
                Err.Clear
                DuplicatesExist = True
                RowNumberCollection.Add CheckRange(lRow, 1).Row
                If DuplicateRange Is Nothing Then
                    Set DuplicateRange = _
                        CheckRange.Cells(lRow, 1)
                Else
                    Set DuplicateRange = Union(DuplicateRange, _
                        CheckRange.Cells(lRow, 1))
                End If
            End If
        End If
    Next lRow
    On Error GoTo 0

    If DuplicatesExist = False Then
        MsgBox 'No duplicates exist.', vbInformation
    Else
        With DuplicateRange.EntireRow
            If WriteListOfDuplicates Then
                Worksheets.Add After:=DuplicateRange.Parent
                .Copy Destination:=Range('A1')
                If AddRowNumberToList Then
                    Columns('A').Insert
                    Set StartCell = Range('A1')
                    For Each Element In RowNumberCollection
                        StartCell.Value = 'Row ' & Element
                        Set StartCell = StartCell.Offset(1, 0)
                    Next Element
                End If
            End If
            If FormatDuplicates Then .Font.ColorIndex = 3
            If DeleteDuplicates Then .Delete
        End With
    End If

End Sub

[file name=Doublons_20051103143009.zip size=12054]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/Doublons_20051103143009.zip[/file]

Message édité par: alol.ita, à: 05/11/2005 01:52

 

[alol.ita]

En fait il faut changer 2 valeurs booléennes
DeleteDuplicates = True ' donc suppression des lignes
WriteListOfDuplicates = False 'pas d'archives des doublons en feuil4.

Sub doublons()

Dim CheckRows As Range
Dim ColumnsToMatch As Variant
Dim DeleteDuplicates As Boolean
Dim FormatDuplicates As Boolean
Dim WriteListOfDuplicates As Boolean
Dim AddRowNumberToList As Boolean
Dim lLBound As Long
Dim lUBound As Long
Dim CheckRange As Range
Dim SubArray As Variant
Dim FieldsCollection As New Collection
Dim RowNumberCollection As New Collection
Dim Dummy As Long
Dim DuplicateRange As Range
Dim DuplicatesExist As Boolean
Dim lRow As Long
Dim CollectionKey As String
Dim OffsetValue() As Long
Dim StartCell As Range
Dim Element As Variant
Dim Counter As Long

'adapter les 6 variables ci-dessous pour mettre à jour
'les paramètres de travail de la macro
Set CheckRows = Rows('1:1000')
ColumnsToMatch = Array('A', 'B', 'D')
DeleteDuplicates = True
FormatDuplicates = False
WriteListOfDuplicates = False
AddRowNumberToList = True


lLBound = LBound(ColumnsToMatch)
lUBound = UBound(ColumnsToMatch)

Set CheckRange = Intersect(Range(ColumnsToMatch(lLBound) & _
':' & ColumnsToMatch(lLBound)), CheckRows)

ReDim OffsetValue(lUBound - lLBound + 1)

For Counter = lLBound To lUBound
OffsetValue(Counter) = Range(ColumnsToMatch(Counter) & ':' & _
ColumnsToMatch(Counter)).Column - CheckRange.Column
Next Counter

On Error Resume Next
SubArray = CheckRange.Value
For lRow = 1 To UBound(SubArray, 1)
If SubArray(lRow, 1) <> '' Then
CollectionKey = ''
For Counter = lLBound To lUBound
CollectionKey = CollectionKey & _
CheckRange(lRow, 1).Offset(0, _
OffsetValue(Counter)).Value
Next Counter
FieldsCollection.Add Dummy, CStr(CollectionKey)
If Err.Number = 457 Then
Err.Clear
DuplicatesExist = True
RowNumberCollection.Add CheckRange(lRow, 1).Row
If DuplicateRange Is Nothing Then
Set DuplicateRange = _
CheckRange.Cells(lRow, 1)
Else
Set DuplicateRange = Union(DuplicateRange, _
CheckRange.Cells(lRow, 1))
End If
End If
End If
Next lRow
On Error GoTo 0

If DuplicatesExist = False Then
MsgBox 'No duplicates exist.', vbInformation
Else
With DuplicateRange.EntireRow
If WriteListOfDuplicates Then
Worksheets.Add After:=DuplicateRange.Parent
.Copy Destination:=Range('A1')
If AddRowNumberToList Then
Columns('A').Insert
Set StartCell = Range('A1')
For Each Element In RowNumberCollection
StartCell.Value = 'Row ' & Element
Set StartCell = StartCell.Offset(1, 0)
Next Element
End If
End If
If FormatDuplicates Then .Font.ColorIndex = 3
If DeleteDuplicates Then .Delete
End With
End If

End Sub