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

Question

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

pilas31 · Answer

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+

cletess · Answer

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

pilas31 · Answer

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,

ccm81 · Answer

Bonjour à tous les deux 

une autre proposition  (pour un nombre quelconque de valeurs de A)
https://www.cjoint.com/?3AkqmlR3R3f   

bonne suite

michel_m · Answer

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 ?

pilas31 · Answer

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+

ccm81 · Answer

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

michel_m · Answer

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

ccm81 · Answer

> 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

ccm81 · Answer

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

cletess · Answer

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

Macro Excel: suppression de lignes sous conditions

11 réponses

Discussions similaires