Merci DanielEssaie :
VB:Option Base 1 Sub test() Dim Tabl1 As Variant, Tabl2 As Variant, Tabl3(), I As Long, J As Long Dim Teste As Boolean, Ctr As Long Tabl1 = Range("B2", Cells(Rows.Count, 5).End(xlUp)) Tabl2 = Application.Transpose(Range("H2", Cells(Rows.Count, 8).End(xlUp))) For I = 1 To UBound(Tabl1, 1) Teste = False For J = 1 To UBound(Tabl2) If Tabl1(I, 1) = Tabl2(J) Then Teste = True Exit For End If Next J If Teste = False Then Ctr = Ctr + 1 ReDim Preserve Tabl3(4, Ctr) Tabl3(1, Ctr) = Tabl1(I, 1) Tabl3(2, Ctr) = Tabl1(I, 2) Tabl3(3, Ctr) = Tabl1(I, 3) Tabl3(4, Ctr) = Tabl1(I, 4) End If Next I Range("B2", Cells(Rows.Count, 5).End(xlUp)) = "" [B2].Resize(UBound(Tabl3, 2), UBound(Tabl3, 1)) = Application.Transpose(Tabl3) End Sub
Daniel
Avec la macro précédente le tableau est trié sur la colonne B, ça ne me paraît pas gênant.A part ajouter une colonne temporaire, je ne sais pas conserver l'ordre initial des lignes lors du tri, du-moins je n'ai pas trouvé.
Sub Supprimer()
Dim t#, d As Object, tablo, i&, x$, P As Range, resu(), n&
t = Timer
Set d = CreateObject("Scripting.Dictionary")
With Feuil1 'CodeName à adapter
'---liste sans doublon---
tablo = .[H2:H10000] 'matrice, plus rapide
For i = 1 To UBound(tablo)
x = tablo(i, 1)
If x <> "" Then d(x) = ""
Next
'---repérage des lignes à conserver---
Set P = .[B2:E1000000] '999 999 lignes...
tablo = P.Columns(1) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 1)
For i = 1 To UBound(tablo)
x = tablo(i, 1)
If x <> "" Then If d.Exists(x) Then n = n + 1 Else resu(i, 1) = 1 'repère
Next
'---restitution, tri et suppression---
Application.ScreenUpdating = False
If .FilterMode Then .ShowAllData 'si la feuille est filtrée
P.Columns(2).EntireColumn.Insert 'colonne auxiliaire
P.Columns(2) = resu
P.Sort P(1, 2), Header:=xlNo 'tri pour regrouper les 1 et accélérer
On Error Resume Next 'si aucune SpecialCell
Intersect(P.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow, P).Delete xlUp 'supprime les cellules vides
P.Columns(2).EntireColumn.Delete 'supprime la colonne auxiliire
With .UsedRange: End With 'actualise les barres de défilement
End With
MsgBox n & " ligne" & IIf(n > 1, "s", "") & " supprimée" & IIf(n > 1, "s", "") & " en " & Format(Timer - t, "0.00 \sec")
End Sub
Clap, clap. Je me coucherai moins bête ce soir (l'utilisation du dictionnaire).Bonjour KTM, danielco, mapomme, le forum,
Avec la macro précédente le tableau est trié sur la colonne B, ça ne me paraît pas gênant.
Maintenant si vous voulez conserver l'ordre initial prenez ce fichier (2) et la macro :
On utilise une colonne auxiliaire, ça prend un peu plus de temps : 2,9 secondes.VB:Sub Supprimer() Dim t#, d As Object, tablo, i&, x$, P As Range, resu(), n& t = Timer Set d = CreateObject("Scripting.Dictionary") With Feuil1 'CodeName à adapter '---liste sans doublon--- tablo = .[H2:H10000] 'matrice, plus rapide For i = 1 To UBound(tablo) x = tablo(i, 1) If x <> "" Then d(x) = "" Next '---repérage des lignes à conserver--- Set P = .[B2:E1000000] '999 999 lignes... tablo = P.Columns(1) 'matrice, plus rapide ReDim resu(1 To UBound(tablo), 1 To 1) For i = 1 To UBound(tablo) x = tablo(i, 1) If x <> "" Then If d.Exists(x) Then n = n + 1 Else resu(i, 1) = 1 'repère Next '---restitution, tri et suppression--- Application.ScreenUpdating = False If .FilterMode Then .ShowAllData 'si la feuille est filtrée P.Columns(2).EntireColumn.Insert 'colonne auxiliaire P.Columns(2) = resu P.Sort P(1, 2), Header:=xlNo 'tri pour regrouper les 1 et accélérer On Error Resume Next 'si aucune SpecialCell Intersect(P.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow, P).Delete xlUp 'supprime les cellules vides P.Columns(2).EntireColumn.Delete 'supprime la colonne auxiliire With .UsedRange: End With 'actualise les barres de défilement End With MsgBox n & " ligne" & IIf(n > 1, "s", "") & " supprimée" & IIf(n > 1, "s", "") & " en " & Format(Timer - t, "0.00 \sec") End Sub
A+
Merci Job 75Bonjour KTM, danielco, mapomme, le forum,
Avec la macro précédente le tableau est trié sur la colonne B, ça ne me paraît pas gênant.
Maintenant si vous voulez conserver l'ordre initial prenez ce fichier (2) et la macro :
On utilise une colonne auxiliaire, ça prend un peu plus de temps : 2,9 secondes.VB:Sub Supprimer() Dim t#, d As Object, tablo, i&, x$, P As Range, resu(), n& t = Timer Set d = CreateObject("Scripting.Dictionary") With Feuil1 'CodeName à adapter '---liste sans doublon--- tablo = .[H2:H10000] 'matrice, plus rapide For i = 1 To UBound(tablo) x = tablo(i, 1) If x <> "" Then d(x) = "" Next '---repérage des lignes à conserver--- Set P = .[B2:E1000000] '999 999 lignes... tablo = P.Columns(1) 'matrice, plus rapide ReDim resu(1 To UBound(tablo), 1 To 1) For i = 1 To UBound(tablo) x = tablo(i, 1) If x <> "" Then If d.Exists(x) Then n = n + 1 Else resu(i, 1) = 1 'repère Next '---restitution, tri et suppression--- Application.ScreenUpdating = False If .FilterMode Then .ShowAllData 'si la feuille est filtrée P.Columns(2).EntireColumn.Insert 'colonne auxiliaire P.Columns(2) = resu P.Sort P(1, 2), Header:=xlNo 'tri pour regrouper les 1 et accélérer On Error Resume Next 'si aucune SpecialCell Intersect(P.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow, P).Delete xlUp 'supprime les cellules vides P.Columns(2).EntireColumn.Delete 'supprime la colonne auxiliire With .UsedRange: End With 'actualise les barres de défilement End With MsgBox n & " ligne" & IIf(n > 1, "s", "") & " supprimée" & IIf(n > 1, "s", "") & " en " & Format(Timer - t, "0.00 \sec") End Sub
A+