XL 2016 Supprimer des lignes qui contiennent des mots d'une liste

[jmgill]

Bonjour

J’utilise pour traiter un fichier une macro de Jacques Boisgontier et une autre de PierreJean. Ces 2 macros fonctionnent parfaitement pour mon cas mais à un détail près. Le fichier fourni par la préfecture est un recueil national de 50 000 adresses. Je joins un échantillon comme exemple.

Dans la première colonne j’utilise la macro de Pierrejean pour éliminer les noms qui ne m’intéressent pas. Ces noms sont rangés dans la feuille « Exclusions ». Cette macro fonctionne très bien mais ne supprime qu’une seule fois les noms de la feuille « fichier final » alors qu'ils peuvent être présents de multiples fois. Je suppose qu’il faudrait ajouter quelque part une boucle de traitement.

Sub supprimer()

Application.ScreenUpdating = False

tablo = Sheets("Exclusions").Range("A2:A" & Sheets("Exclusions").Range("A655536").End(xlUp).Row)

For n = LBound(tablo, 1) To UBound(tablo, 1)

Set c = Sheets("Fichier final").Columns("A").Find(tablo(n, 1), LookIn:=xlValues, lookat:=xlWhole)

If Not c Is Nothing Then

Rows(c.Row).Delete

End If

Next n

Application.ScreenUpdating = True

End Sub


Le fichier étant national, je ne voudrais garder que les noms de mon arrondissement dans la 3ème colonne. Pour ce faire j’utilise la macro de Jacques Boisgontier qui élimine tous les noms qui ne sont pas compris dans la feuille « villes ». Les noms de villes étant précédés et suivis de données qui ne m’intéressent pas (code postal, cedex, etc) j’ai mis un * devant et derrière le nom de la ville. Or contrairement à la routine de Pierrejean, ici ça ne fonctionne pas, il faut que le nom soit parfaitement identique, ce qui est le second problème.


Sub supLignesListe2()

'Application.ScreenUpdating = False

Set f1 = Sheets("Fichier final")

Set f2 = Sheets("Villes")

colCode = Application.Match("Ville", f1.[A1:Z1], 0)

colListe = Application.Match("Ville", f2.[A1:Z1], 0)

If Not IsError(p2) Then

n = f2.Cells(65000, colListe).End(xlUp).Row

Liste = f2.Cells(2, colListe).Resize(n - 1)

End If

If Not IsError(col) And Not IsError(colListe) Then

For i = f1.Cells(Rows.Count, colCode).End(xlUp).Row To 2 Step -1

c = Application.Match(f1.Cells(i, colCode), Liste, 0)

If IsError(c) Then f1.Rows(i).Delete

Next i

End If

'Application.ScreenUpdating = True

End Sub


Merci pour votre aide

 

[Staple1600]

Bonjour et bienvenue sur le forum

[Juste pour infos]
Ci-dessous le point 1 de la charte du forum.

1 - Conformité RGPD
Tout message ou fichier déposé sur ce site ne doit pas comporter de données à caractère personnel (DCP).
Il convient d’anonymiser toutes les données permettant d’identifier directement ou indirectement une personne.

[/Juste pour infos]
Joins plutôt une version allégée et surtout anonymisée de ton fichier.
(NB: Il suffit de modifier les colonne Noms et Adresses en y mettant des données fictives)
Le code existant fonctionnera néanmoins puisqu'il se base sur la colonne Ville.
Un truc dans ce genre là

Sinon pour supprimer les doublons (j'en ai mis dans mon exemple)
Tu peux utiliser la fonctionnalité: Supprimer les doublons
(Sur le ruban: Données/Supprimer les doublons)
Tu peux aussi les "marquer" avec une mise en forme conditionnelle (comme sur ma copie écran) : Accueil/Mise en forme conditionnelle/Valeurs en double
PS: Ne pas oublier de mettre ci et là des noms fictifs avec tes caractères d' exclusion
*rent*
*auto*
*capital*
*carrosserie*
*garage*
*parcours*
*prioris*
*ada*
*bail*

 

[cp4]

Bonjour @jmgill , @Staple1600 ,

Un essai à tester. Cependant, J'ai retiré les astérisques et il y a un caractère vide à la fin de chaque cellule. Je me demandais pourquoi mon code ne fonctionnait pas correctement. Pour info, le cas où il y a des # n'a pas été traité. De plus, AIMON LAURENT (ligne 518) et ALIN FLORENT (ligne 652) ont été supprimés.

Option Explicit

Sub Supprime_Lignes()
   Dim Exclu, Fexc As Worksheet, Cel As Range, Fvil As Worksheet, Vill, dl As Long, X As Range, i As Long
   Set Fexc = Sheets("exclusions")
   Set Fvil = Sheets("villes")

   Set Exclu = Fexc.Range("A2:A" & Fexc.Range("A" & Rows.Count).End(xlUp).Row)
   Set Vill = Fvil.Range("A2:A" & Fvil.Range("A" & Rows.Count).End(xlUp).Row)

   With Sheets("Fichier final")
      'suppression liste exclusions
      For Each X In Exclu
         dl = .Range("A" & Rows.Count).End(xlUp).Row

         For i = dl To 4 Step -1
            If .Cells(i, 1).Value Like "*" & UCase(X) & "*" Then .Rows(i).Delete
         Next i
      Next X

      'suppression liste villes
      For Each X In Vill
         dl = .Range("A" & Rows.Count).End(xlUp).Row

         For i = dl To 4 Step -1
            If .Cells(i, 1).Value Like "*" & UCase(X) & "*" Then .Rows(i).Delete
         Next i
      Next X
   End With

   MsgBox "Traitement terminé!"
End Sub

Bon dimanche.

ps: Tu devrais vite retirer ton fichier car il contient des données personnelles. Chose non permise sur le forum. Il faut toujours rendre ses données anonymes.

 

[jmgill]

Bonjour @jmgill , @Staple1600 ,

Un essai à tester. Cependant, J'ai retiré les astérisques et il y a un caractère vide à la fin de chaque cellule. Je me demandais pourquoi mon code ne fonctionnait pas correctement. Pour info, le cas où il y a des # n'a pas été traité. De plus, AIMON LAURENT (ligne 518) et ALIN FLORENT (ligne 652) ont été supprimés.

Option Explicit

Sub Supprime_Lignes()
   Dim Exclu, Fexc As Worksheet, Cel As Range, Fvil As Worksheet, Vill, dl As Long, X As Range, i As Long
   Set Fexc = Sheets("exclusions")
   Set Fvil = Sheets("villes")

   Set Exclu = Fexc.Range("A2:A" & Fexc.Range("A" & Rows.Count).End(xlUp).Row)
   Set Vill = Fvil.Range("A2:A" & Fvil.Range("A" & Rows.Count).End(xlUp).Row)

   With Sheets("Fichier final")
      'suppression liste exclusions
      For Each X In Exclu
         dl = .Range("A" & Rows.Count).End(xlUp).Row

         For i = dl To 4 Step -1
            If .Cells(i, 1).Value Like "*" & UCase(X) & "*" Then .Rows(i).Delete
         Next i
      Next X

      'suppression liste villes
      For Each X In Vill
         dl = .Range("A" & Rows.Count).End(xlUp).Row

         For i = dl To 4 Step -1
            If .Cells(i, 1).Value Like "*" & UCase(X) & "*" Then .Rows(i).Delete
         Next i
      Next X
   End With

   MsgBox "Traitement terminé!"
End Sub

Bon dimanche.

ps: Tu devrais vite retirer ton fichier car il contient des données personnelles. Chose non permise sur le forum. Il faut toujours rendre ses données anonymes.

Merci pour la réponse rapide.
La routine pour supprimer les exclusions en colonne A fonctionne mais pas celle des villes, il ne se passe rien.
Je constate qu'elle est identique à la première, or je ne veux pas supprimer les lignes dont les noms de villes sont dans la liste mais au contraire les garder et supprimer touts les autres (mais j'interprète peut-être mal le code).
De plus comme je comprends que la routine positionne une * avant et après les mots en majuscule, je préférerai les mettre moi-même dans la feuille "villes", comme ça je pourrai traité le genre de cas suivant:
*LILLE * pour ignorer le CEDEX de LILLE CEDEX par exemple.
Je rejoins un fichier simplifié et plus clair.

Quant à la suppression de mon premier fichier joint je n'ai pas trouvé le moyen de reprendre la main dessus.

Merci encore

 

[Staple1600]

Re

[Pour infos]
ll suffit de cliquer sur Editer puis Gérer les pièces jointes
et ensuite tu peux la supprimer

 

[cp4]

Merci pour la réponse rapide.
La routine pour supprimer les exclusions en colonne A fonctionne mais pas celle des villes, il ne se passe rien.
Je constate qu'elle est identique à la première, or je ne veux pas supprimer les lignes dont les noms de villes sont dans la liste mais au contraire les garder et supprimer touts les autres (mais j'interprète peut-être mal le code).
De plus comme je comprends que la routine positionne une * avant et après les mots en majuscule, je préférerai les mettre moi-même dans la feuille "villes", comme ça je pourrai traité le genre de cas suivant:
*LILLE * pour ignorer le CEDEX de LILLE CEDEX par exemple.
Je rejoins un fichier simplifié et plus clair.

Quant à la suppression de mon premier fichier joint je n'ai pas trouvé le moyen de reprendre la main dessus.

Merci encore

Bonsoir jmgill , Staple1600 ,

@jmgill : J'ai répondu comme j'ai cru comprendre la demande.
Donc, il faut supprimer les lignes exclusions et garder villes.

J'essaie de t'aider avec mes petites connaissances. Je pense que ton idée pour traiter le cas cedex n'est pas la bonne approche.

Bonne soirée.

 

[cp4]

@jmgill : Aucun réaction depuis 7 jours pas normal? Mais bon, je l'ai fait comme je l'ai compris. Je poste. à moins que tu n'aies solutionné ton problème. Tu aurais pu partager la solution.

Option Explicit
Option Compare Text
Sub Supprime_Lignes()
   Dim Exclu, Fexc As Worksheet, Cel As Range, Fvil As Worksheet, Vill, dl As Long, X As Range, i As Long
   Set Fexc = Sheets("exclusions")
   Set Fvil = Sheets("villes")

   Set Exclu = Fexc.Range("A2:A" & Fexc.Range("A" & Rows.Count).End(xlUp).Row)
   Set Vill = Fvil.Range("A2:A" & Fvil.Range("A" & Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
   With Sheets("Fichier final")
      '***suppression liste exclusions *****************************************************
            For Each X In Exclu
               dl = .Range("A" & Rows.Count).End(xlUp).Row
               For i = dl To 4 Step -1
                  If .Cells(i, 1).Value Like "*" & X & "*" Or IsError(.Cells(i, 3).Value) Then .Rows(i).Delete
               Next i
            Next X
      ''**************************************************************************************

      '***On récupère sans doublon toutes les villes/cp **************************************
      Dim dico As Object, cle
      Set dico = CreateObject("scripting.dictionary")
      dico.CompareMode = vbTextCompare   'comparaison texte ==> minuscule/majuscules identiques
      For Each Cel In .Range("C4:C" & .Range("A" & Rows.Count).End(xlUp).Row)
            dico(Cel.Value) = ""
      Next
      ''**************************************************************************************
      '***On efface toutes les villes de la liste du dictionnaire dico ***********************

      For Each X In Vill
         For Each cle In dico.Keys
            If cle Like "*" & X & "*" Then dico.Remove (cle)
         Next cle
      Next X
     ''**************************************************************************************

      '***On supprime les lignes figurant dans le dictionnaire dico ***********************
For Each cle In dico.Keys
dl = .Range("A" & Rows.Count).End(xlUp).Row
For i = dl To 4 Step -1
If .Cells(i, 3).Value = cle Then .Rows(i).Delete
Next i
Next cle
     ''**************************************************************************************

   End With

   MsgBox "Traitement terminé!"
Application.ScreenUpdating = True

Set Fexc = Nothing: Set Fvil = Nothing: Set Exclu = Nothing: Set Vill = Nothing
End Sub

Bon week-end.

 

[cp4]

On gagne quelques secondes avec ce code

'***On supprime les lignes figurant dans le dictionnaire dico ***********************
For Each cle In dico.Keys
   dl = .Range("A" & Rows.Count).End(xlUp).Row
   With .Range("A3:C" & dl)
      .AutoFilter field:=3, Criteria1:=cle
      .Offset(1, 0).EntireRow.Delete
      .AutoFilter
   End With
Next cle
''**************************************************************************************

 

[jmgill]

On gagne quelques secondes avec ce code

'***On supprime les lignes figurant dans le dictionnaire dico ***********************
For Each cle In dico.Keys
   dl = .Range("A" & Rows.Count).End(xlUp).Row
   With .Range("A3:C" & dl)
      .AutoFilter field:=3, Criteria1:=cle
      .Offset(1, 0).EntireRow.Delete
      .AutoFilter
   End With
Next cle
''**************************************************************************************

Merci beaucoup pour les réponses, je vais adapter