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
