Sub Tirages()
Dim t, ntirages&, d As Object, tablo, i&, x$, y$, z$, n&, c As Range
t = Timer
ntirages = 100000 'nombre maximum de tirages, à adapter
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'mode de calcul manuel
'---liste des arrangements---
Range("C2:F" & Rows.Count).ClearContents 'RAZ
Set d = CreateObject("Scripting.Dictionary")
tablo = [A2:A144]
For i = 1 To 143
x = Left(tablo(i, 1), 1)
y = Mid(tablo(i, 1), 2, 1)
z = Right(tablo(i, 1), 1)
d(x & " " & y & " " & z) = ""
d(x & " " & z & " " & y) = ""
d(y & " " & x & " " & z) = ""
d(y & " " & z & " " & x) = ""
d(z & " " & x & " " & y) = ""
d(z & " " & y & " " & x) = ""
Next
[D2].Resize(d.Count) = Application.Transpose(d.Keys)
[D2].Resize(d.Count).TextToColumns [D2], xlDelimited, Space:=True 'commande Convertir
[C2].Resize(d.Count) = "=RAND()"
'---tris aléatoires---
[M2:O144].ClearContents 'RAZ
With [C1].CurrentRegion.Resize(, 4)
For n = 1 To ntirages
If n Mod 100 = 0 Then Application.StatusBar = Format(n, "#,##0") & " tirages" 'pour faire patienter...
.Sort .Columns(1), Header:=xlYes
.Columns(1).Calculate 'recalcul de la colonne
For Each c In Range("I2:K13")
c.Calculate 'recalcule la cellule
If c > 14 Then GoTo 1
Next c
[M2:O144] = [D2:F144].Value
Application.Calculation = xlCalculationAutomatic 'mode de calcul automatique
Application.ScreenUpdating = True
MsgBox Format(n, "#,##0") & " tirages réalisés en " & Format(Timer - t, "0.0") & " secondes", , "143 arrangements trouvés"
Exit Sub
1 Next n
End With
Application.Calculation = xlCalculationAutomatic 'mode de calcul automatique
MsgBox "Aucun résultat en " & Format(ntirages, "#,##0") & " tirages..."
End Sub
.
