Sub Supprimer()
Dim d As Object, c As Range, a, i&
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each c In Sheets("PLANNING").Range("D6:DVH6,D14:DVH14,D22:DVH22,D30:DVH30,D38:DVH38,D46:DVH46,D54:DVH54,D62:DVH62,D70:DVH70,D78:DVH78,D86:DVH86,D94:DVH94,D102:DVH102,D110:DVH110,D118:DVH118,D126:DVH126,D134:DVH134,D142:DVH142,D150:DVH150,D158:DVH158,D166:DVH166")
d(c.Value) = ""
Next
For Each c In Sheets("PLANNING").Range("D174:DVH174,D182:DVH182,D190:DVH190,D198:DVH198,D206:DVH206,D214:DVH214")
d(c.Value) = ""
Next
'---suppressions en Feuil1---
With Sheets("Feuil1").ListObjects(1).Range
a = .Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(a)
a(i, 1) = IIf(d.exists(a(i, 1)), "sup", 0)
Next
Application.ScreenUpdating = False
.Columns(2).Insert xlToRight 'insère une colonne auxiliaire
.Columns(2) = a
.Sort .Columns(2), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
On Error Resume Next 'si aucune SpecialCell
.Columns(2).Offset(1).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete 'Offset(1) évite les en-têtes
.Columns(2).Delete xlToLeft 'supprime la colonne auxiliaire
With .Parent.UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub