Sub VillesDoublons()
'Job
t1 = Timer
With Sheets("RESULTAT")
Application.ScreenUpdating = False
Sheets("VILLES (2)").Cells.Copy .Cells
.[A2:G65536].Sort Key1:=.[A2], Order1:=xlAscending, Header:=xlYes 'tri sur les noms
.[3:3].Insert 'insertion de ligne nécessaire...
.[G3].Formula = "=AND($A3<>$A2,$A3<>$A4)"
.[H3] = True
.[A2:G65536].AdvancedFilter xlFilterInPlace, CriteriaRange:=.[G2:G3]
.[A3:G65536].SpecialCells(xlCellTypeVisible).Delete xlUp
.[A2:G65536].AdvancedFilter xlFilterInPlace, CriteriaRange:=.[H2:H3]
.[G3:G3].ClearContents
.[3:3].Delete
.Activate
End With
MsgBox (Timer - t1)
End Sub
Sub ListeVillesDoublons()
'JB
t1 = Timer
Set f1 = Sheets("villes (2)")
Set f2 = Sheets("resultat")
Set champ = f1.Range("A3:G" & f1.[A65000].End(xlUp).Row)
Set mondico = CreateObject("Scripting.Dictionary")
f2.[A1:G65000].ClearContents
For Each c In champ
mondico.Item(c.Value) = mondico.Item(c.Value) + 1
Next c
ligne = 1
For Each c In champ
If mondico.Item(c.Value) > 1 Then
c.Resize(, 6).Copy f2.Cells(ligne, 1)
ligne = ligne + 1
End If
Next c
f2.[A1].CurrentRegion.Sort Key1:=f2.[A1], Order1:=xlAscending, Header:=xlNo
MsgBox (Timer - t1)
End Sub
Sub ListeVillesDoublonsRapide()
'JB
t1 = Timer
Set f1 = Sheets("villes (2)")
Set f2 = Sheets("resultat")
a = f1.Range("A3:G" & f1.[A65000].End(xlUp).Row).Value
Set mondico = CreateObject("Scripting.Dictionary")
f2.[A1:G65000].ClearContents
For i = 1 To UBound(a)
mondico.Item(a(i, 1)) = mondico.Item(a(i, 1)) + 1
Next i
ligne = 1
Dim c()
ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
For i = 1 To UBound(a)
If mondico.Item(a(i, 1)) > 1 Then
For k = 1 To UBound(a, 2): c(ligne, k) = a(i, k): Next k
ligne = ligne + 1
End If
Next i
f2.[A1].Resize(mondico.Count, UBound(a, 2)) = c
f2.[A1].CurrentRegion.Sort Key1:=f2.[A1], Order1:=xlAscending, Header:=xlNo
MsgBox (Timer - t1)
End Sub