Sub supprimerLignes()
Dim t, d As Object, tablo, i&, col%, n&
t = Timer
Application.ScreenUpdating = False
'---liste du Dictionary---
Set d = CreateObject("Scripting.Dictionary")
tablo = Sheets("Feuil2").[A1].CurrentRegion.Resize(, 2) 'au moins 2 éléments
For i = 2 To UBound(tablo)
d(tablo(i, 1)) = ""
Next
If d.Count = 0 Then Exit Sub
'---traitement du tableau---
With Sheets("Feuil1").[A1].CurrentRegion
col = .Columns.Count + 1 'colonne auxiliaire
.Columns(col) = "a"
tablo = .Resize(, col)
For i = 2 To UBound(tablo)
If Not d.exists(tablo(i, 2)) Then tablo(i, col) = 1: n = n + 1
Next
.Columns(col) = Application.Index(tablo, , col) 'restitution
.Resize(, col).Sort .Columns(col), xlDescending 'tri pour accélérer (les 1 sont en bas)
If n Then .Columns(col).SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
.Columns(col) = ""
With .Parent.UsedRange: End With 'actualise les barres de défilement
End With
MsgBox n & " lignes supprimées en " & Format(Timer - t, "0.00 \s")
End Sub