Macro Excel: suppression de lignes sous conditions

Résolu
cletess Messages postés 40 Statut Membre -  
cletess Messages postés 40 Statut Membre -
Bonjour à tous,

Je cherche une macro pour me débarrasser de lignes excel sous certaines conditions.
L'idée principale est de supprimer toute les lignes après que la variable 'B' ait atteint son pic minimal, et ce, pour chaque valeur de la variable 'A'.

Vu que j'ai 3 valeurs de cette variable A (1,2 et 3) et pour chacune d'entres elles, un ensemble de valeurs de B, j'obtiens 3 minimum et je cherche un moyen de ne sélectionner pour chacune des valeurs de A que les lignes avant l'atteinte du pic (pic compris).
A B
1 22
1 20
1 14
1 22
2 10
2 22
2 66
3 44
3 74
3 10
3 20

Dans l'exemple si dessus, 3 minimums: 14 (pour A=1), 10 (pour A=2) et 10 (pour A=3) et il faut que je supprime pour chaque valeur de A les lignes qui suivent le minimum (lignes en gras)

Merci d'avance pour toute aide potentielle

11 réponses

  1.
    pilas31 Messages postés 1878 Statut Contributeur 648
     
    Bonjour,

    Voici une proposition de macro : 
    Sub Supprimer()

Dernligne = Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row

'initialise les min avec une valeur arbitrairement grande
A1min = 10000
A2min = 10000
A3min = 10000

'cherche le minimum pour chaque valeur de A
For Ligne = 1 To Dernligne
    Select Case Cells(Ligne, 1)
        Case 1
            If Cells(Ligne, 2) < A1min Then
                A1min = Cells(Ligne, 2)
                L1 = Ligne
            End If
        Case 2
            If Cells(Ligne, 2) < A2min Then
                A2min = Cells(Ligne, 2)
                L2 = Ligne
            End If
        Case 3
            If Cells(Ligne, 2) < A3min Then
                A3min = Cells(Ligne, 2)
                L3 = Ligne
            End If
    End Select
Next Ligne

'élimine les lignes au delà des L1, L2 et L3
For Ligne = Dernligne To 1 Step -1
    If (Cells(Ligne, 1) = 1 And Ligne > L1) Or (Cells(Ligne, 1) = 2 And Ligne > L2) Or (Cells(Ligne, 3) = 3 And Ligne > L3) Then
        Rows(Ligne).Delete Shift:=xlUp
    End If
Next Ligne
End Sub


    A tester
    A+
    0
  2. cletess Messages postés 40 Statut Membre
     
    Merci beaucoup pour cette réponse, je teste ça dés demain matin !

    Juste une clarification:

    Les bases de données dans lesquelles je dois appliquer cette macro ont 56 différentes valeurs de A. Si je comprends bien cette macro, je devrais l'allonger pour chaque valeur de A, c'est bien correct ?

    Encore milles fois merci
    0
    1. pilas31 Messages postés 1878 Statut Contributeur 648
       
      Oui dans ce cas il est peut-être pertinent d'utiliser des structure de tableau car cela risque d'être pénible de faire un "case" avec 56 valeurs !
      J'éssaies de trouver une variante de l'algorithme plus adaptée.
      A+
      0
    2. cletess Messages postés 40 Statut Membre
       
      https://transvol.sgsi.ucl.ac.be/download.php?id=f030c3823725078f

      Pour un exemple plus 'adéquat', voilà un des fichiers que je dois traiter (si vous pouvez y accèder).

      Les 56 valeurs sont répertoriées dans la colonne 'Frame' et il faut que les minimums soient calculés sur 'LgObj Z'.

      ça peut éventuellement aider pour visualiser !

      Les bases de données sont démesurées, sans macro, ça me prends des heures pour faire un fichier et j'en ai 30 à faire :D

      Merci beaucoup,
      0
    3. pilas31 Messages postés 1878 Statut Contributeur 648
       
      Ok je regarde par rapport à ma dernière proposition de macro....
      0
  3. pilas31 Messages postés 1878 Statut Contributeur 648
     
    Voila une nouvelle proposition avec un tableau à 56 valeurs qui devrait être plus adaté.

    Attention il y a deux prérequis implicites :
    Les valeurs de A sont de 1 à 56
    Les valeurs minimales sont toujours différentes de zéro

    Sinon il faudra modifier le code : 

    Sub Supprimer56() 
Dim Tabmin(56, 2) As Integer 
Dernligne = Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row 
'cherche le minimum pour chaque valeur de A 
For Ligne = 1 To Dernligne 
    If Cells(Ligne, 2) < Tabmin(Cells(Ligne, 1), 1) Or Tabmin(Cells(Ligne, 1), 1) = 0 Then 
        Tabmin(Cells(Ligne, 1), 1) = Cells(Ligne, 2) 
        Tabmin(Cells(Ligne, 1), 2) = Ligne 
    End If 
Next Ligne 
'élimine les lignes au delà des L1, L2 ....L56
For Ligne = Dernligne To 1 Step -1 
    If Ligne > Tabmin(Cells(Ligne, 1), 2) Then 
        Rows(Ligne).Delete Shift:=xlUp 
    End If 
Next Ligne 
End Sub


    finalement le code est plus simple....
    A+

    Cordialement,
    0

  5. Vous n’avez pas trouvé la réponse que vous recherchez ?

    Posez votre question
  6. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Bonjour

    Et une troisième !!! 

    Sub xxxxx()
Dim Nbre As Byte, Cptr As Byte
Dim Debut As Long, Fin As Long, Ligne As Long, Mini As Double

Application.ScreenUpdating = False
With Sheets("feuil2")
     Nbre = Application.Max(.Columns("D"))
          For Cptr = 1 To Nbre
               Debut = .Columns("D").Find(Cptr, .Range("D1")).Row
               Fin = Debut + Application.CountIf(.Columns("D"), Cptr) - 1
               Mini = Application.Min(.Range(.Cells(Debut, "S"), .Cells(Fin, "S")))
               Ligne = .Columns("S").Find(Mini, .Range("S1")).Row + 1
               .Rows(Ligne).Delete
          Next
End With
End Sub

    question:
    et si il ya 2 valeurs de pic égale pour un m^me frame ?
    0
  7. pilas31 Messages postés 1878 Statut Contributeur 648
     
    Bonjour à vous deux michel et ccm81,

    j'ai testé ma macro sur le fichier original qui fait 45849 lignes !!! c'est trés long. de l'ordre de 30 mn.

    Je ne sais pas si avec vos propositions les performances sont meilleures..A tester

    A+
    0
  8. ccm81 Messages postés 11033 Statut Membre 2 434
     
    re salut à tous

    évidemment sur 50000 lignes, ça change tout
    une tentative d'optimisation et comme je n'ai qu'excel 2003 ....) 

    Option Explicit  

Const lideb = 2  
Const coA = "A"  
Const coB = "B"  

Private Sub btOK_Click()  
Dim lifin As Long, li As Long, mini, a, b  
Dim dico As Object, nudico As Long, nbdico As Long  
Dim lid As Long, lif As Long, limini As Long, lim As Long  
Application.ScreenUpdating = False
' ligne de fin  
lifin = Range(coA & Rows.Count).End(xlUp).Row  
' dictionaire des valeurs colonne coA  
Set dico = CreateObject("Scripting.dictionary")  
For li = lideb To lifin  
  a = Range(coA & li).Value  
  b = Range(coB & li).Value  
  If Not dico.exists(a) Then  
    dico.Add a, b  
  End If  
Next li  
' nombre de valeurs colonne coA  
nbdico = dico.Count  
' suppression  
lif = lifin  
For nudico = nbdico To 1 Step -1  
  b = dico.Item(nudico)  
  ' ligne de (nudico,b) dans la feuille  
  lid = Range(coB & lideb - 1 & ":" & coB & lif).Find(b, , , xlWhole).Row  
  ' recherche ligne mini pour cette valeur de a  
  mini = Application.Min(Range(coB & lid & ":" & coB & lif))  
  limini = Range(coB & lid - 1 & ":" & coB & lif).Find(mini, , , xlWhole).Row  
  ' suppression lignes après limini  
  If limini <> lif Then Rows(limini + 1 & ":" & lif).Delete  
  lif = lid - 1  
Next nudico  
Set dico = Nothing  
Application.ScreenUpdating = True
End Sub

    bonne suite
    0
  9. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Pour moi 15,7 sec avec 512 Mo RAM proc 3 ghz

    edit: il ya un pb du à une formule dans la colonne D, je regarde

    Michel
    0
    1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      La macro modifiée 
      Sub xxxxx() 
Dim Nbre As Byte, Cptr As Byte, Derlig as Long 
Dim Debut As Long, Fin As Long, Ligne As Long, Mini As Double 

Start = Timer 'pour essai 

Application.ScreenUpdating = False 
With Sheets("feuil2") 
     derlig = Columns("D").Find("*", , , , , xlPrevious).Row 
     'supprime les formules dans colonne D 
     T_xx = Application.Transpose(.Range("D2:D" & derlig).Value) 
     .Range("D2:D" & derlig) = Application.Transpose(T_xx) 
      
     Nbre = Application.Max(.Columns("D")) 
          For Cptr = 1 To Nbre 
               Debut = .Columns("D").Find(Cptr, .Range("D1")).Row 
               Fin = Debut + Application.CountIf(.Columns("D"), Cptr) - 1 
               Mini = Application.Min(.Range(.Cells(Debut, "S"), .Cells(Fin, "S"))) 
               Ligne = .Columns("S").Find(Mini, .Range("S1")).Row + 1 
               Rows(Ligne).Delete 
          Next 
End With 

MsgBox Timer - Start  'pour essai 
End Sub
      0
    2. cletess Messages postés 40 Statut Membre
       
      Cette macro ne supprime-t'elle pas uniquement les lignes dans lesquelles se trouvent les minimums ?
      0
    3. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      Elle supprime la ligne en dessous du minimum comme demandé

      Ligne = .Columns("S").Find(Mini, .Range("S1")).Row + 1
      Rows(Ligne).Delete
      0
    4. pilas31 Messages postés 1878 Statut Contributeur 648
       
      Bonjour michel,

      Je crois qu'il faut supprimer toutes les lignes qui suivent une fois que le minimum a été atteint.
      Dans l'exemple de la demande initiale, il faut supprimer 2 22 et 2 66.
      Mais je pense que ta methode et trés efficace et on doit pouvoir facilement l'adapter en supprimant les lignes de "Ligne" jusqu'a "Fin".

      A+
      0
  10. ccm81 Messages postés 11033 Statut Membre 2 434
     
    > michel

    je sais bien que la curiosité est un vilain défaut, mais peux tu m'envoyer le fichier à tester au format excel 2003?

    merci

    cordialement CCM81
    0
    1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      bonjour,

      pour CCM81: Ok je t'envoie ça sans la macro puisque notre ami Pilas31 m'annonce qu'il faut supprimer toutes les lignes

      pour Pilas31: en effet, mes yeux vieillissant ...

      Donc je reprend le code; il y a aussi des formules dans la colonne T faisant appel à la colonne (celle du mini) d'où de splendides REF sur les lignes...."le" piège
      0
    2. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      Re

      ci joint le classeur 2003
      https://www.cjoint.com/?3AlkI22h5sa

      La macro est corrigée mais quelques vérifs à faire
      0
    3. cletess Messages postés 40 Statut Membre
       
      Tout juste 3 secondes pour un fichier de 75.000 lignes ...

      Je suis impressionné ! Merci infiniment !
      0
    4. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      La macro corrigée en espèrant que.... (je vais bruler un cierge à l'église du coin) :o)
      curieux durée 8 sec au lieu de 15 ... ? 

      Sub xxxxx()
Dim Derlig As Long, Nbre As Byte, Cptr As Byte
Dim Debut As Long, Fin As Long, Ligne As Long, Mini As Double

Dim start As Single
start = Timer 'pour essai rapidité à supprimer

Application.ScreenUpdating = False
With Sheets("feuil2")
      'supprime les formules dans colonne D
     Derlig = Columns("D").Find("*", , , , , xlPrevious).Row
     'supprime les formules dans colonne D
     T_xx = Application.Transpose(.Range("D2:D" & Derlig).Value)
     .Range("D2:D" & Derlig) = Application.Transpose(T_xx)
     
     Nbre = Application.Max(.Columns("D")) 'nombre de frame
     For Cptr = 1 To Nbre
          'recherche le pic mini de chaque frame
          Debut = .Columns("D").Find(Cptr, .Range("D1")).Row
          Fin = Debut + Application.CountIf(.Columns("D"), Cptr) - 1
          Mini = Application.Min(.Range(.Cells(Debut, "S"), .Cells(Fin, "S")))
          'détruit les lignes sous le mini jusquau changement de frame
          Ligne = .Columns("S").Find(Mini, .Range("S1")).Row
          'Si la ligne du mini n'est pas la dernière ligne du frame
          If Ligne <> Fin Then Rows(CStr(Ligne + 1) & ":" & CStr(Fin)).Delete
     Next
     'recopie la formule colonne T
     Derlig = Columns("D").Find("*", , , , , xlPrevious).Row
     Range("T3").AutoFill Destination:=Range("T3:T" & Derlig)
End With
MsgBox Timer - start 'pour essai rapidité à supprimer
End Sub
      0
    5. pilas31 Messages postés 1878 Statut Contributeur 648
       
      Re bonjour à vous deux,
      Moi je ne suis plus dans la course, 8 secondes, 5 secondes, vous êtes des champions de l'optimisation !!!

      Par contre michel j'ai un doute sur cette séquence :
      'détruit les lignes sous le mini jusquau changement de frame
      Ligne = .Columns("S").Find(Mini, .Range("S1")).Row

      Je me demande si il ne faut pas plutot écrire..
      Ligne = .Columns("S").Find(Mini, .Range("S" & Debut - 1)).Row

      A votre avis
      0
  11. ccm81 Messages postés 11033 Statut Membre 2 434
     
    re

    > michel
    Merci pour le fichier 2003, ça m'a permis de corriger quelques erreurs et de tester.
    Au passage je t'ai pompé la suppression et la recopie des formules (re-merci)
    Durée 5.5 s (sur un 2Ghz) 

    Option Explicit 

Const lideb = 2 
Const coA = "D" 
Const coB = "S" 

Private Sub btOK_Click() 
Dim lifin As Long, li As Long, mini, a 
Dim dico As Object, nudico As Long, nbdico As Long 
Dim lid As Long, lif As Long, limini As Long 
Dim t, T_xx 
t = Timer 
Application.ScreenUpdating = False 
' ligne de fin 
lifin = Range(coA & Rows.Count).End(xlUp).Row 
'supprime les formules dans colonne coA 
 T_xx = Application.Transpose(Range(coA & lideb & ":" & coA & lifin).Value) 
 Range(coA & lideb & ":" & coA & lifin) = Application.Transpose(T_xx) 
' dictionaire des valeurs colonne coA 
Set dico = CreateObject("Scripting.dictionary") 
For li = lideb To lifin 
  a = Range(coA & li).Value 
  If Not dico.exists(a) Then 
    dico.Add a, 1 
  End If 
Next li 
' nombre de valeurs colonne coA 
nbdico = dico.Count 
' suppression 
lif = lifin 
For nudico = nbdico To 1 Step -1 
  ' ligne de a dans la feuille 
  lid = Range(coA & lideb - 1 & ":" & coA & lif).Find(nudico, , , xlWhole).Row 
  ' recherche ligne mini pour cette valeur de a 
  mini = Application.Min(Range(coB & lid & ":" & coB & lif)) 
  limini = Range(coB & lid - 1 & ":" & coB & lif).Find(mini, , , xlWhole).Row 
  ' suppression lignes après limini 
  If limini <> lif Then Rows(limini + 1 & ":" & lif).Delete 
  lif = lid - 1 
Next nudico 
Set dico = Nothing 
'recopie la formule colonne T 
lifin = Columns(coA).Find("*", , , , , xlPrevious).Row 
Range("T3").AutoFill Destination:=Range("T3:T" & lifin) 
Application.ScreenUpdating = True 
MsgBox Timer - t & " s" 
End Sub


    cordialement
    0
  12. cletess Messages postés 40 Statut Membre
     
    Les deux fonctionnent à merveille maintenant:

    3.7 sec pour celle de Ccm81 et 3.5 pour celle de Michel avec la correction.

    Vous me tirez une épine d'une taille incroyable hors du pied ! Merci beaucoup encore à tous les trois !

    CL
    0

Discussions similaires

Transformer un chiffre en lettres dans excel sans macro
vincentphilippos -
tontong -

6 réponses