Macro Excel: suppression de lignes sous conditions

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

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

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

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

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