XL 2016 Suppression de feuils en gardant des feuilles selon une caractéristique.

Sub Supression()
  Dim sh As Worksheet
  Application.DisplayAlerts = False
  For Each sh In ThisWorkbook.Worksheets
  If IsError(Application.Match(sh.Name, Sheets("Insupprimable").Range("b3:b" & Sheets("Insupprimable").Cells(Rows.Count, "B").End(xlUp).Row), 0)) Then
  If sh.Name <> ActiveSheet.Name Then sh.Delete
  End If
  Next
  Application.DisplayAlerts = True
End Sub

Sub Supression()
Dim d As Object, s As Object
Set d = CreateObject("Scripting.Dictionary")
For Each s In Sheets
  If Application.CountIf([B:B], s.Name) = 0 Then d(s.Name) = ""
Next
If d.Count = Sheets.Count Then MsgBox "Il faut conserver au moins une feuille !", 48: Exit Sub
If d.Count = 0 Then Exit Sub
Application.DisplayAlerts = False
Sheets(d.keys).Delete
End Sub

Sub Supression()
Dim d As Object, s As Object
Set d = CreateObject("Scripting.Dictionary")
For Each s In Sheets
  If s.Index > 2 And Application.CountIf([B:B], s.Name) = 0 Then d(s.Name) = ""
Next
If d.Count = 0 Then Exit Sub
Application.DisplayAlerts = False
Sheets(d.keys).Delete
End Sub