classement (excel, maths?)

Sub Minimum()
Dim NbAlea&, NbTirage&, mini&, h&, P As Range, d As Object, dc&
Dim tirage&, c As Range, j%, n&, i&, k%
NbAlea = [N6] 'nombre d'aleas
NbTirage = [N7] 'nombre de tirages
mini = 1000000
Application.ScreenUpdating = False
With [A1].CurrentRegion.Resize(, 5)
  .Copy [G1]
  h = .Rows.Count
End With
Set P = [G1].Resize(h, 5)
'---liste des valeurs sans doublon classée---
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
  d(c.Value) = d(c.Value) + 1
Next
dc = d.Count
Range("Q2:S" & Rows.Count) = "" 'RAZ
[Q2].Resize(dc) = Application.Transpose(d.keys)
[R2].Resize(dc) = Application.Transpose(d.items)
[Q2].Resize(dc, 2).Sort [R2], xlDescending, Header:=xlNo 'classement
[S2].Resize(NbAlea) = "=RAND()" 'ALEA() sur les premiers
'---détarmination du minimum---
For tirage = 1 To NbTirage
  Application.Calculation = xlCalculationManual
  [Q2].Resize(NbAlea, 3).Sort [S2], Header:=xlNo 'classement aléatoire
  For Each c In [Q2].Resize(dc)
    '---comptage préalable---
    For j = 1 To 5
      n = 0
      For i = 1 To h
        If P(i, j).Interior.ColorIndex = xlNone Then
          For k = 1 To 5
            If P(i, k) = c Then
              n = n + 1
              If n = c(1, 2) Then GoTo 1
              Exit For
            End If
          Next k
        End If
    Next i, j
    '---permutations et repérages avec la couleur jaune---
1   If n = c(1, 2) Then
      For i = 1 To h
        If P(i, j).Interior.ColorIndex = xlNone Then
          For k = 1 To 5
            If P(i, k) = c Then
              P(i, k) = P(i, j)
              P(i, j) = c
              P(i, j).Interior.ColorIndex = 6
              Exit For
            End If
          Next k
        End If
      Next i
    End If
  Next c
  P.Interior.ColorIndex = xlNone 'RAZ du repérage
  Application.Calculation = xlCalculationAutomatic 'recalcul
  If Round([M3]) < mini Then mini = Round([M3]): P.Copy [U1] 'mémorisation
Next tirage
[U1].Resize(h, 5).Copy P 'restitution
[U1].Resize(h, 5) = "" 'RAZ
End Sub

Sub Minimum()
Dim NbAlea&, NbTirage&, mini&, h&, P As Range, t, test() As Boolean
Dim d As Object, dc&, tirage&, c As Range, j%, n&, i&, k%, memo
NbAlea = [N6] 'nombre d'aleas
NbTirage = [N7] 'nombre de tirages
mini = 1000000
Application.ScreenUpdating = False
With [A1].CurrentRegion.Resize(, 5)
  .Copy [G1]
  h = .Rows.Count
End With
Set P = [G1].Resize(h, 5)
t = P 'tableau VBA
ReDim test(1 To h, 1 To 5) 'tableau VBA
'---liste des valeurs sans doublon classée---
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
  d(c.Value) = d(c.Value) + 1
Next
dc = d.Count
Range("Q2:S" & Rows.Count) = "" 'RAZ
[Q2].Resize(dc) = Application.Transpose(d.keys)
[R2].Resize(dc) = Application.Transpose(d.items)
[Q2].Resize(dc, 2).Sort [R2], xlDescending, Header:=xlNo 'classement
[S2].Resize(NbAlea) = "=RAND()" 'ALEA() sur les premiers
'---détermination du minimum---
For tirage = 1 To NbTirage
  [Q2].Resize(NbAlea, 3).Sort [S2], Header:=xlNo 'classement aléatoire
  For Each c In [Q2].Resize(dc)
    '---comptage préalable---
    For j = 1 To 5
      n = 0
      For i = 1 To h
        If Not test(i, j) Then
          For k = 1 To 5
            If t(i, k) = c Then
              n = n + 1
              If n = c(1, 2) Then GoTo 1
              Exit For
            End If
          Next k
        End If
    Next i, j
    '---permutations dans t, repérages dans test---
1   If n = c(1, 2) Then
      For i = 1 To h
        If Not t(i, j) Then
          For k = 1 To 5
            If t(i, k) = c Then
              t(i, k) = t(i, j)
              t(i, j) = c
              test(i, j) = True
              Exit For
            End If
          Next k
        End If
      Next i
    End If
  Next c
  ReDim test(1 To h, 1 To 5) 'RAZ du repérage
  P = t
  If Round([M3]) < mini Then mini = Round([M3]): memo = P 'mémorisation
Next tirage
P = memo 'restitution
End Sub