Supprimer lignes avec Select Case

Bonjour à tous,

Avec le code suivant, je supprime toutes les lignes sauf celles de la colonne "A" qui commencent par le texte "HMY27" et "HMA96" d’où la ligne de code suivante :

Select Case Left(a(i, 1), 5)
Case "HMY27", "HMA96"

Maintenant, je souhaite garder en plus toutes les lignes dont les cellules en colonne "A" commencent par le texte "856" mais je ne sais pas comment ajouter cette ligne de code ci-dessous au code déjà existant :

Select Case Left(a(i, 1), 3) '
Case "856"

Merci pour vos retours.

Bien à vous.

Sub SupprimerLigne()

     Application.ScreenUpdating = False

     Dim a As Variant, b As Variant
     Dim nc As Long, i As Long, k As Long

     nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
     a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
     ReDim b(1 To UBound(a), 1 To 1)
     For i = 1 To UBound(a)

          '    Select Case Left(a(i, 1), 3) 'je veux ajouter ce select
          '      Case "856"

          Select Case Left(a(i, 1), 5)
               Case "HMY27", "HMA96"
               Case Else
                    Select Case Left(a(i, 1), 3)
                         Case "856"
                         Case Else
                              k = k + 1
                              b(i, 1) = 1
                    End Select
          End Select
     Next i
     If k > 0 Then
          Application.ScreenUpdating = False
          With Range("A2").Resize(UBound(a), nc)
               .Columns(nc).Value = b
               .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
               .Resize(k).EntireRow.Delete
          End With
          Application.ScreenUpdating = True
     End If

     Application.ScreenUpdating = True

End Sub

Bonjour BsAlv,

Merci pour votre retour.

La mise à jour du code est fonctionnelle et me donne le résultat souhaité.

Grand MERCI.

Amitiés.

Salut Harzer,
Salut BsAlv,

Avec une cellule disponible chaque fois qu'il faut supprimer un ancêtre sans se tracasser de coder l'affaire!

Private Sub Worksheet_Change(ByVal Target As Range)
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, [SUPPRIMER]) Is Nothing Then
    If Target <> "" Then
        For x = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
            If Left(Cells(x, 1), Len(Target)) = CStr(Target) Then Rows(x).EntireRow.Delete shift:=xlUp
        Next
    End If
    Target.ClearContents
End If
'
Application.EnableEvents = True
Application.ScreenUpdating = True
'
End Sub

A+

Salut Curulis & les autres membres,

Merci pour ton retour.

Merci également pour cette nouvelle manière pour solutionner le problème.

Je t'avoues que l'idée me plaît beaucoup, je vais garder cette solution précieusement sur une clé USB, peut-être un jour je l'utiliserais.

Amitiés.