Macro Excel: suppression de lignes sous conditions [Résolu/Fermé]

Signaler
Messages postés
38
Date d'inscription
jeudi 10 janvier 2013
Statut
Membre
Dernière intervention
5 avril 2018
-
Messages postés
38
Date d'inscription
jeudi 10 janvier 2013
Statut
Membre
Dernière intervention
5 avril 2018
-
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

Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
585
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+
Messages postés
38
Date d'inscription
jeudi 10 janvier 2013
Statut
Membre
Dernière intervention
5 avril 2018

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
Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
585
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+
Messages postés
38
Date d'inscription
jeudi 10 janvier 2013
Statut
Membre
Dernière intervention
5 avril 2018

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,
Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
585
Ok je regarde par rapport à ma dernière proposition de macro....
Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
585
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,
Messages postés
9578
Date d'inscription
lundi 18 octobre 2010
Statut
Membre
Dernière intervention
12 octobre 2020
1 921
Bonjour à tous les deux

une autre proposition (pour un nombre quelconque de valeurs de A)
https://www.cjoint.com/?3AkqmlR3R3f

bonne suite
Messages postés
16233
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
13 octobre 2020
3 047
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 ?
Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
585
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+
Messages postés
9578
Date d'inscription
lundi 18 octobre 2010
Statut
Membre
Dernière intervention
12 octobre 2020
1 921
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
Messages postés
16233
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
13 octobre 2020
3 047
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
Messages postés
16233
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
13 octobre 2020
3 047
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
Messages postés
38
Date d'inscription
jeudi 10 janvier 2013
Statut
Membre
Dernière intervention
5 avril 2018

Cette macro ne supprime-t'elle pas uniquement les lignes dans lesquelles se trouvent les minimums ?
Messages postés
16233
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
13 octobre 2020
3 047
Elle supprime la ligne en dessous du minimum comme demandé

Ligne = .Columns("S").Find(Mini, .Range("S1")).Row + 1
Rows(Ligne).Delete
Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
585
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+
Messages postés
9578
Date d'inscription
lundi 18 octobre 2010
Statut
Membre
Dernière intervention
12 octobre 2020
1 921
> 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
Messages postés
38
Date d'inscription
jeudi 10 janvier 2013
Statut
Membre
Dernière intervention
5 avril 2018

Tout juste 3 secondes pour un fichier de 75.000 lignes ...

Je suis impressionné ! Merci infiniment !
Messages postés
16233
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
13 octobre 2020
3 047
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
Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
585
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
Messages postés
16233
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
13 octobre 2020
3 047
oui, tu as raison, merci
Messages postés
9578
Date d'inscription
lundi 18 octobre 2010
Statut
Membre
Dernière intervention
12 octobre 2020
1 921
Et 5.5 s .... avec la correction de pilas31
Messages postés
9578
Date d'inscription
lundi 18 octobre 2010
Statut
Membre
Dernière intervention
12 octobre 2020
1 921
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
Messages postés
38
Date d'inscription
jeudi 10 janvier 2013
Statut
Membre
Dernière intervention
5 avril 2018

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