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

[Valoute]

Bonjour,
je m'explique je cherche à supprimer toutes les feuilles correspondantes à un critère d'une cellule exemple pour garder les feuilles que j'ai besoins:

Sub Supression()
Dim Compteur As Integer, Nom As String
    Application.DisplayAlerts = False
    For Compteur = Worksheets.Count To 1 Step -1
        Nom = Sheets(Compteur).Name
        Select Case Nom
        Case Range("B3").Value, Range("B4").Value 'Etc...
           
        Case Else
            Sheets(Compteur).Delete
        End Select
    Next Compteur
    Application.DisplayAlerts = True
End Sub

Comment je peux faire pour qu'il comprenne que le nom de page à pas supprimer c'est en rapport avec une cellule.

 

[Jacky67]

Bonjour,
je m'explique je cherche à supprimer toutes les feuilles correspondantes à un critère d'une cellule exemple pour garder les feuilles que j'ai besoins:

Sub Supression()
Dim Compteur As Integer, Nom As String
    Application.DisplayAlerts = False
    For Compteur = Worksheets.Count To 1 Step -1
        Nom = Sheets(Compteur).Name
        Select Case Nom
        Case Range("B3").Value, Range("B4").Value 'Etc...
         
        Case Else
            Sheets(Compteur).Delete
        End Select
    Next Compteur
    Application.DisplayAlerts = True
End Sub

Comment je peux faire pour qu'il comprenne que le nom de page à pas supprimer c'est en rapport avec une cellule.

Bonjour,
Ceci supprime toutes les feuilles sauf celles ou le nom est inscrit entre b3 et bx

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

 

[job75]

Bonjour Valoute, Jacky67,

Ou aussi :

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

Bonne journée.

 

[Valoute]

La macro fonctionne très bien c'est super cool, mais je suis exposé à un nouveau problème auquel je n'ai aucune compétence c'est comment faire pour y ajouter une selection plus manuel exemple: ajouter l'impossibilité de supprimer Sheets(1) et Sheets(2) en plus des feuilles situés en B.

 

[job75]

Re,

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

Edit : j'ai aussi ajouté If d.Count = 0 Then Exit Sub dans ma macro du post #3.

Bonne fin de soirée.

 

[job75]

Re,

De quel ajout parlez-vous ?

Je ne vois vraiment pas comment la macro du post #5 peut beuguer.

Edit : vous avez supprimé votre post #6... Pas glop ça

A+