Suppression de lignes en fonction d'une selection multiple (range)

Bonjour à toutes et à tous,

Je débute un peu dans le VBA et je rencontre un problème dans ma macro.

Voici le sujet:

Je dispose d'un tableau d'environ 12000 lignes et 30 colonnes sur la feuille 1.

Dans la colonne "J", j'ai une liste de personnes (environ 200) (nom et prénom dans la même cellule).

Dans la feuille 2, j'ai un tableau avec une liste de personnes (15).

Je souhaiterai supprimer dans la feuille 1 toutes les lignes dont la cellule "J" ne soit pas l'une des personnes de la liste en feuille 2.

Voici ce que j'ai actuellement, mais qui ne fonctionne pas...

Sub DeleteRowNoInclude()
Dim xRow As Range
Dim rng As Range
Dim WorkRng As Range
Dim xStr As Range
On Error Resume Next
xTitleId = "Suppression de lignes"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Zone a analyser", xTitleId, WorkRng.Address, Type:=8)
xStr = Application.InputBox("Preparateur a supprimer", xTitleId, "", Type:=2)
Application.ScreenUpdating = False
For i = WorkRng.Rows.Count To 1 Step -1
    Set xRow = WorkRng.Rows(i)
    Set rng = xRow.Find(xStr, LookIn:=xlValues)
    If rng Is Nothing Then
       Application.DisplayAlerts = False
       Rows(i).Select
       Selection.Delete
       'xRow.Delete
       Application.DisplayAlerts = True
    End If
Next
Application.ScreenUpdating = True

End Sub

L' avantage de mon code, c'est que la macro m'ouvre dans un premier temps une fenêtre qui me permet de sélectionner la zone à analyser (je sélectionne alors les 12000 lignes de la colonne J) puis une deuxième fenêtre me permettant de sélectionner la liste des 15 personnes à conserver. Mais je n'ai absolument pas le résultat attendu...

Merci d'avance pour votre aide et bonne journée.

Bonjour,

Pourquoi faire une macro ?

Tu peux mettre des filtres sur les intitulés afin de filtrer (décocher les 15 personnes sur la feuille 2, ce qui n'est pas énorme) puis supprimer tout ce qu'il te reste.

Plus fiable et plus rapide.

Bien à toi.

C’est ce que je faisais avant mais je souhaiterai que cela soit automatique car je dois le faire une fois par jour.

Ça permet également d'éviter les oublis ou erreurs si quelqu'un d'autre que moi devait modifier ce fichier.

Re,

Remplace ton code par ceci.

Sub DeleteRowNoInclude()
Dim xRow As Range
Dim rng As Range
Dim WorkRng As Range
Dim xStr As Range

On Error Resume Next
xTitleId = "Suppression de lignes"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Zone a analyser", xTitleId, WorkRng.Address, Type:=8)

Set xStr = Application.Selection
Set xStr = Application.InputBox("Preparateur a supprimer", Type:=8)

Application.ScreenUpdating = False
For i = WorkRng.Rows.Count To 1 Step -1
    Set xRow = WorkRng.Rows(i)
    Set a = xStr.Find(xRow)
    If a Is Nothing Then
       Application.DisplayAlerts = False
       Rows(i).Select
       Selection.Delete
       Application.DisplayAlerts = True
    End If
Next
Application.ScreenUpdating = True

End Sub

Je te remercie pour ton aide.

Cependant, cela me supprime ma liste en feuille 2 et non les lignes correspondantes aux personnes en feuille 1 :s

Je n'arrive pas à voir d'où pourrais venir le souci...

Bonjour,

Je ne vois pas non plus car chez moi cela fonctionne.

Peux tu faire un fichier d'exemple ?

Merci

Bonjour à tous,

Désolé pour cette réponse tardive.

J'ai modifié ma macro et cela fonctionne maintenant.

Je vous la mets ci-dessous si jamais cela intéresse.

Sub DeleteRowNoInclude1()
Dim xRow As Range
Dim rng As Range
Dim WorkRng As Range
Dim xStr As Range

xTitleId = "Suppression de lignes"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Zone a analyser", xTitleId, WorkRng.Address, Type:=8)

Set xStr = Application.Selection
Set xStr = Application.InputBox("Preparateur a conserver", Type:=8)

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("feuil1").Activate

For i = WorkRng.Rows.Count To 2 Step -1

    Set xRow = WorkRng.Rows(i)
    Set a = xStr.Find(xRow)
    If a Is Nothing Then
       Worksheets("feuil1").Rows(xRow.Row).Delete
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub