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