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