Sub supprimeDoublons()
Dim cellulecourante As Range
Dim cellulesuivante As Range
Set cellulecourante = ActiveSheet.Range("A133")
ActiveSheet.Range("A133").Sort Key1:=Range("A133"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Do While Not IsEmpty(cellulecourante) = True
Set cellulesuivante = cellulecourante.Offset(1, 0)
If cellulesuivante.Value = cellulecourante.Value Then
cellulecourante.EntireRow.Delete
End If
Set cellulecourante = cellulesuivante
Loop
End Sub
Sub DictionarySupprLignDoublon()
Application.ScreenUpdating = False
Dim mondico As Variant: Set mondico = CreateObject("Scripting.Dictionary")
NoPremLig = 2 'prem ligne de départ
NoDernLig = Cells(Rows.Count, "A").End(xlUp).Row 'dern ligne en colonne A
'
NoLig = NoPremLig
Do While NoLig <= NoDernLig
If Cells(NoLig, "A") <> "" Then
Var$ = Cells(NoLig, "B") & Cells(NoLig, "C") & Cells(NoLig, "D")
If Not mondico.Exists(Var$) Then 'ajoute
mondico.Add Var$, Var$: NoLig = NoLig + 1
Else 'suppr car existe déjà
Rows(NoLig).EntireRow.Delete
End If
Else
NoLig = NoLig + 1
End If
Loop
Set mondico = Nothing
Application.ScreenUpdating = True
End Sub
Sub Test()
Dim t() As Variant
f = Range("a65536").End(xlUp).Row
' Tableau en mémoire :
t = Range(Cells(133, 1), Cells(f, 2))
' Suppresion de la zone (toutes les données qui sont en mémoire)
Range(Cells(133, 1), Cells(f, 2)).Clear
' Redimension du tabeau pour les clefs (colone en mémoire 3 = concatenantion et 4 = Nombre 1 si doublon)
ReDim Preserve t(1 To UBound(t), 1 To 4)
For i = 1 To UBound(t, 1)
t(i, 3) = t(i, 1) & t(i, 2)
x = i + 1
For j = x To UBound(t, 1)
t(j, 3) = t(j, 1) & t(j, 2)
If t(i, 3) = t(j, 3) Then
t(j, 4) = t(j, 4) + 1
End If
Next j
Next i
' Tableau 2 ou seront stoker les données en mémoire (avec les meme dimension que le tableau supprimer)
Dim t2() As Variant
ReDim t2(1 To UBound(t), 1 To 2)
cpt = 1
For i = 1 To UBound(t, 1)
If t(i, 4) = Empty Then ' Si la colonne 4 du premier tableau "t" est vide la ligne est unique
t2(cpt, 1) = t(i, 1) ' transfert des cases d'un tableau a l'autre ici case 1 de la ligne i dans le tableau mémoire
t2(cpt, 2) = t(i, 2) ' transfert des cases d'un tableau a l'autre ici case 2 de la ligne i dans le tableau mémoire
cpt = cpt + 1 ' ici compteur pour remplir le nouveau tableau "t2"
End If
Next i
' ici reconstituer le tableau sans doublon = colle le tableau 2 "t2" a l'endroit de celui supprimer
Cells(133, 1).Resize(UBound(t2, 1), UBound(t2, 2)) = t2
End Sub