Supprimer des lignes suivant un critère

[lvlat]

Bonjour à tous,
Je seche un peu sur un problème. J'ai dans une feuille un nombre indéterminé de lignes dont la valeur de la premiere colonne est PARIS, puis un nombre de lignes dont la valeur de la premiere colonne est LYON, puis d'autres commencant par MARSEILLE.

Je copie cette feuille 3 fois et souhaite ne récupérer que les lignes débutant par "PARIS" dans la premiere, par "LYON" dans la deuxieme etc.

Au départ j'ai pensé à faire une boucle toute simple, mais la feuille peut compter jusqu'à 15.000 lignes, et la ca prend des plombes.

Quelqu'un aurait une astuce? Pas la peine de me donner le code pour la copie des pages etc, tout ca c'est fait, j'aimerais simplement avoir quelque chose du genre "Si colonne A = "LYON" ou "MARSEILLE" supprimer les lignes correspondantes.

Pour l'instant j'en suis a chercher la premiere occurence, compter combien de fois elle apparait et supprimer les lignes qui vont de la premiere occurence à premiere occurence + nbre de lignes. C'est assez bancal comme solution!

Merci,

Mat.

 

[mutzik]

Re : Supprimer des lignes suivant un critère

bonjour,

manuellement, je trierai les données sur cette colonne, reste plus quà supprimer tout le reste
sinon, il faut que tu le fasse tout les combien ?

 

[Efgé]

Re : Supprimer des lignes suivant un critère

Bonjour lvlat et bienvenu sur le forum,
Je pourrais; peut être, te faire une proposition, mais il faudrait un fichier exemple sans données confidentielles, pour voir la structure de ta feuille de base, son nom et les différentes feuilles existantes dans le classeur.
Faut il créer les feuilles au fur et à mesure ou existent elles?

A te re lire
Cordialement

EDIT Bonjour Bertrand et amitiées, content de te croiser....

 

[lvlat]

Re : Supprimer des lignes suivant un critère

Bonjour, merci de me réponde aussi rapidement.

Bertrand : la manip en elle meme n'est pas longue à faire mais il faut le faire sur une dizaine de fichiers et la ca devient plus fastidieux, d'ou la macro.

FG : Les fichiers ne sont pas du tout compliqués : imagine une feuille qui sert d'annuaire téléphonique pour 3 villes dans lequel il y a 15.000 personnes.
Colonne A : la ville, col B : le nom, col C : le numéro de téléphone. A partir de cette feuille unique j'aimerais créer 3 feuilles, une par ville.

J'espère etre a peu prés clair,

Mat.

 

[JNP]

Re : Supprimer des lignes suivant un critère

Bonjour Lvlat et bienvenue, Fred, Bertrand 🙂,
Une suggestion :

Sub test()
Dim Plage As Range
With Sheets("Feuil1").Range("A1:A15000")
    Set c = .Find("PARIS", LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            If Not Plage Is Nothing Then
                Set Plage = Union(Plage, Range(c, c.Offset(0, 2)))
            Else
                Set Plage = Range(c, c.Offset(0, 2))
            End If
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
Plage.Copy Sheets("Feuil2").Range("A1")
End Sub

sur 15000 lignes, environ 15 secondes de traitement, soit moins d'une minute pour 3 villes 😛...
Bonne journée 😎

 

[lvlat]

Re : Supprimer des lignes suivant un critère

Salut JNP,
Merci pour ta réponse mais il y a une dizaine de fichiers à opérer, du coup ca va faire long. Je pense alors rester sur la solution tordue dont j'ai parlé au dessus, meme si ce n'est pas trés 'pro'!

Mat.

 

[JNP]

Re : Supprimer des lignes suivant un critère

Re 🙂,
Je relisais ton premier post, tes données semblent triées 🙄...
Alors teste ceci, ça devrait mieux te convenir 😛

Sub Test2()
Dim Cellule1 As Range, Cellule2 As Range
If Range("A1") = "PARIS" Then
Set Cellule1 = Range("A1")
Else
Set Cellule1 = Range("A1:A15000").Find(What:="PARIS", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
    xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=False)
End If
Set Cellule2 = Range("A1:A15000").Find(What:="PARIS", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
    xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
    , SearchFormat:=False)
Range(Cellule1, Cellule2).Copy Sheets("Feuil2").Range("A1")
End Sub

Bonne soirée 😎

 

[lvlat]

Re : Supprimer des lignes suivant un critère

Ah oui, plutot que de supprimer tous ce que je ne veux pas je n'ai qu'à copier que ce que je veux, bien vu! Je vais essayer ca, merci bcp pour l'idée et le code.
Mat.

 

[Efgé]

Re : Supprimer des lignes suivant un critère

Bonjour à tous, le fil, le forum,
Une proposition sur la base d'un code de Roger.
Les prérecquis:
Le classeur d'arrivée est dans le même dossier que les classeurs sources.
Le classeur d'arrivée possède un feuille dont le nom est le nom de la ville (PARIS, LYON,...)

Sub test()
Dim dossier As Object, fichier As Object
Dim i&, j&, m&, s$, dDat(), oDat, dat(), g&
Dim Rep$
Application.ScreenUpdating = False
dDat = Array(Array("PARIS", dat), Array("LYON", dat))
Rep = ThisWorkbook.Path & "\"
Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Rep & "/")
For Each fichier In dossier.Files
    If Right(fichier.Name, 3) = "xls" And fichier.Name <> ThisWorkbook.Name Then
        Workbooks.Open Filename:=fichier
        With ActiveWorkbook.Sheets("Feuil1")
            For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
              s = UCase(CStr(.Cells(i, 1).Value))
              For j = 0 To UBound(dDat)
                If dDat(j)(0) = s Then
                  oDat = dDat(j)(1)
                  m = 0
                  On Error Resume Next
                  m = 1 + UBound(oDat, 2)
                  On Error GoTo 0
                  ReDim Preserve oDat(0 To 2, 0 To m)
                  oDat(0, m) = Cells(i, 1): oDat(1, m) = Cells(i, 2): oDat(2, m) = Cells(i, 3)
                  dDat(j)(1) = oDat
                End If
              Next
            Next
        End With
        ActiveWorkbook.Close False
    End If
Next fichier
On Error Resume Next
For j = 0 To UBound(dDat)
  oDat = dDat(j)(1)
  With Sheets(dDat(j)(0)).[A1]
    .CurrentRegion.ClearContents
    .Resize(UBound(oDat, 2) + 1, UBound(oDat, 1) + 1).Value = WorksheetFunction.Transpose(oDat)
  End With
Next
On Error GoTo 0
Application.ScreenUpdating = True
End Sub

Cordialement