Re Tanguy, re le Forum
Je te joins une macro que j'ai trouvé sur un autre site et qui te permet de sélectionner les colonnes à tester ainsi que quelques autres options très pratique simplement en changant la valeur False en True ou l'inverse.
J'ai testé cette macro sur 17500 enregistrements et 8 colonnes elle marche très bien.
Il y a aussi l'Excellent fichier de Celeda et Monique sur les doublons à telecharger sur ce site et ou tu trouveras certainement ton bonheur.
Sub DuplicatesInList()
'leo.heuser@get2net.dk, August 17, 2001
'Cette procédure supprime les doublons ou en fait la liste.
'Elle supprime ou inclut dans la liste par lignes entières.
'Une liste des doublons peut être insérée dans une nouvelle feuille
'après la feuille active. Les numéros de lignes peuvent être ajoutés à la liste.
'Plus d'une colonne peut être utilisée pour trouver
'les doublons de la liste. Par exemple, la colonne A peut
'contenir plusieurs entrées avec le nom "Peter"
'la colonne B plusieurs entrées avec "Smith",
'la colonne F plusieurs entrées avec "Oxford St."
'Passer à l'argument ColumnsToMatch la valeur Array("A", "B", "F")
'va inclure dans la liste ou supprimer tous les doublons où
'une correspondance existe entre "A" *et* "B" *et* "F"
' A B F
'1 Name Surname Address
'2 Peter Smith Oxford St.
'3 Peter Smith Regent St.
'4 Peter Jones Oxford St.
'5 Peter Smith Oxford St.
'Avec ces contraintes, seule la 5ème ligne est considérée
'comme un doublon. (trad. fs)
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:17486") 'nombre de lignes du fichier(à modifier)
ColumnsToMatch = Array("A", "B", "D") 'colonnes à tester(peuvent etre changées)
DeleteDuplicates = False 'supression des doublons
FormatDuplicates = True 'mise en évidence des doublons(couleur rouge)
WriteListOfDuplicates = True 'crée une autre feuille avec les doublons
AddRowNumberToList = True 'rajoute le N° de colonne ou etait les doubles
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
@+
Art
