XL 2010 Supprimer des lignes en fonction d'éléménts d'une colonne

[CharlesX]

Bonjour
J'ai pas mal cherché mais je n'ai rien trouvé qui soit à ma portée.
J'ai une liste (colonne) avec des noms, ceux que je veux garder.
J'ai d'autres colonnes dont la première (A) correspond à plein d'autres noms.
Je cherche à écrire le code qui supprimera les lignes des noms qui ne font pas partie de ma liste.
J'ai ce code qui fonctionne bien:

Sub efface_les_autres_noms()

Dim cell As Range
Dim test As Integer
Dim i As Integer


dl = Range("AD65536").End(xlUp).Row

For i = dl To 2 Step -1
If (Cells(i, 1).Value = "NOM1àenlever") Or (Cells(i, 1).Value = "NOM2àenlever") Or (Cells(i, 1).Value = "NOM3àenlever") Then test = 1
If test = 1 Then Rows(i).Delete
test = 0
Next


End Sub

mais j'aurais aimé pouvoir gérer la liste de noms à enlever autrement (il y en a maintenant 50) et je suis sur qu'il y a plus optimisé

Par avance merci
Cdt
Charles

 

[CharlesX]

En pj un fichier d'exemple
La seconde feuille pour remettre les infos initiales après l’exécution de la macro.
J'ai une piste en passant par la fonction trouve mais je n'arrive pas à la transposer en vba avec ma boucle.
Merci

 

[Staple1600]

Bonsoir le fil, le forum

@CharlesX
Une possible macro (en inversant les choses: la liste contient non pas les noms à garder mais les noms à supprimer)

Sub Macro1()
Dim ListeNoms_SUPPR, Rng As Range, NB_LIGNES_SUPPR&
ListeNoms_SUPPR = Application.Transpose(ActiveSheet.Range(ActiveSheet.Cells(2, "G"), ActiveSheet.Cells(Rows.Count, "G").End(xlUp)))
ActiveSheet.Range("$A$1:$A$37").AutoFilter Field:=1, Criteria1:=ListeNoms_SUPPR, Operator:=xlFilterValues
'ou si possible sans surprise
'ActiveSheet.[A1].CurrentRegion.AutoFilter Field:=1, Criteria1:=ListeNoms_SUPPR, Operator:=xlFilterValues
Set Rng = ActiveSheet.AutoFilter.Range
NB_LIGNES_SUPPR = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
If NB_LIGNES_SUPPR > 0 Then
        Application.DisplayAlerts = False
        Rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).Delete
        Application.DisplayAlerts = True
    End If
Rng.AutoFilter
End Sub

PS: Macro à peaufiner si tu décides de l'employer

 

[job75]

Bonjour CharlesX, JM,

Sujet maintes fois traité, voyez le fichier joint et cette macro :

Private Sub CommandButton21_Click()
Application.ScreenUpdating = False
With [A1].CurrentRegion.Offset(1)
    .Columns(1).EntireColumn.Insert 'colonne auxiliaire
    .Columns(0) = "=1/SIGN(COUNTIF(H:H,B2))"
    .Columns(0) = .Columns(0).Value 'supprime les formules
    Union(.Columns(0), .Cells).Sort .Columns(0), xlAscending, Header:=xlNo 'tri pour accélérer
    Intersect(.Columns(0).SpecialCells(xlCellTypeConstants, 16).EntireRow, .Cells).Delete xlUp
    .Columns(0).EntireColumn.Delete 'suppression de la colonne auxiliaire
End With
End Sub

A+

 

[job75]

Re,

2 petits compléments pour peaufiner dans ce fichier (2) :

Private Sub CommandButton21_Click()
Application.ScreenUpdating = False
CommandButton21.Placement = 3 'évite le déplacement (visible)
With [A1].CurrentRegion.Offset(1)
    .Columns(1).EntireColumn.Insert 'colonne auxiliaire
    .Columns(0) = "=1/SIGN(COUNTIF(H:H,B2))"
    .Columns(0) = .Columns(0).Value 'supprime les formules
    Union(.Columns(0), .Cells).Sort .Columns(0), xlAscending, Header:=xlNo 'tri pour accélérer
    Intersect(.Columns(0).SpecialCells(xlCellTypeConstants, 16).EntireRow, .Cells).Delete xlUp
    .Columns(0).EntireColumn.Delete 'suppression de la colonne auxiliaire
End With
CommandButton21.Placement = 2 'état initial
With UsedRange: End With 'actualise les barres de défilement
End Sub

A+

 

[CharlesX]

Merci à tous
J'ai également trouvé une méthode certainement moins élaborée mais qui fonctionne
Une double boucle qui ajoute une valeur dans une nouvelle colonne puis je supprime les lignes dont la valeur de cette colonne est vide

Sheets("temp").Select

Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

dl = Range("A65536").End(xlUp).Row

dl2 = Sheets("LV").Range("A65536").End(xlUp).Row 'les noms que je veux garder sont dans cette feuille et débutent en A2


For i = 2 To dl

For J = 2 To dl2

If Cells(i, 1).Value = Sheets("LV").Cells(J, 1).Value Then
Cells(i, 3).Value = "X"
End If

Next

Next


For i = dl To 2 Step -1
If (Cells(i, 3).Value = "") Then test = 1
If test = 1 Then Rows(i).Delete
test = 0
Next