Sub Tirages()
Dim ntirages, a$(), c As Range, n&, mini, t1, t2, t3, t4
ntirages = 10000 'modifiable
Application.ScreenUpdating = False
'---préparation et formule avec ALEA.ENTRE.BORNES---
ReDim a(1 To Application.CountA([A2:F5]), 1 To 1)
For Each c In [A2:F5]
If c <> "" Then n = n + 1: a(n, 1) = c
Next
ThisWorkbook.Names.Add "Equipes", a 'nom défini
[I4:I21,K4:K21,M4:M21,O4:O21] = "=INDEX(Equipes,RANDBETWEEN(1," & n & "))"
mini = 1000
'---tirages aléatoires---
For n = 1 To ntirages
Calculate
If [B18] < mini Then 'mémorisation du minimum
mini = [B18]
t1 = [I4:I21]: t2 = [K4:K21]
t3 = [M4:M21]: t4 = [O4:O21]
End If
If mini = 0 Then Exit For
Next
'---restitution---
[I4:I21] = t1: [K4:K21] = t2
[M4:M21] = t3: [O4:O21] = t4
End Sub
=OU(""&R21:R22="0";""&R39:R40="0")
Sub Tirages()
Dim ntirages, T As Range, equip$(), c As Range, n&, tablo
Dim nlig&, ncol%, mini, tir&, i&, j%, mem
ntirages = 50 'modifiable
Set T = [I4:O21] 'tableau à renseigner
Application.ScreenUpdating = False
'---préparation---
ReDim equip(1 To Application.CountA([A2:F5]))
For Each c In [A2:F5]
If c <> "" Then n = n + 1: equip(n) = c
Next
tablo = T: nlig = UBound(tablo): ncol = UBound(tablo, 2)
mini = 1000
Randomize
'---tirages aléatoires---
For tir = 1 To ntirages
For i = 1 To nlig Step 2
For j = 1 To ncol Step 2
tablo(i, j) = equip(Int(1 + Rnd * n))
1 tablo(i + 1, j) = equip(Int(1 + Rnd * n))
'---test pour le critère 1---
If Left(tablo(i, j), 3) = Left(tablo(i + 1, j), 3) Then GoTo 1
Next j, i
T = tablo
If [B18] < mini Then mini = [B18]: mem = tablo 'mémorisation
If mini = 0 Then Exit For
Next tir
'---restitution---
T = mem
End Sub
Sub Tirages()
Dim ntirages, T As Range, equip$(), c As Range, n&, tablo, nlig&, ncol%
Dim mini, maxrencontre, tir&, i&, j%, mem, minrencontre
ntirages = 1000 'modifiable
Set T = [I4:O21] 'tableau à renseigner
Application.ScreenUpdating = False
'---préparation---
ReDim equip(1 To Application.CountA([A2:F5]))
For Each c In [A2:F5]
If c <> "" Then n = n + 1: equip(n) = c
Next
tablo = T: nlig = UBound(tablo): ncol = UBound(tablo, 2)
mini = 1000: maxrencontre = 1000
Randomize
'---tirages aléatoires---
For tir = 1 To ntirages
For i = 1 To nlig Step 2
For j = 1 To ncol Step 2
tablo(i, j) = equip(Int(1 + Rnd * n))
1 tablo(i + 1, j) = equip(Int(1 + Rnd * n))
'---test pour le critère 1---
If Left(tablo(i, j), 3) = Left(tablo(i + 1, j), 3) Then GoTo 1
Next j, i
T = tablo
If [A7] < mini Then mini = [A7]: mem = tablo 'mémorisation
'---optimisation du nombre de rencontres (critère 4)---
If [A7] = 0 Then _
If [B9] >= minrencontre And [B10] <= maxrencontre Then _
minrencontre = [B9]: maxrencontre = [B10]: mem = tablo
Next tir
'---restitution---
T = mem
End Sub
'---optimisation du nombre de rencontres (critère 4)---
If [A7] = 0 Then If [B9] = [C9] Then If [B10] < maxrencontre _
Then maxrencontre = [B10]: mem = tablo
Const ntirages = 10000 'nombre maximum de tirages
Dim n&, maxrencontre&, equip$(), compte() 'mémorisation
Sub Tirages()
Dim E As Range, T As Range, nlig&, ncol%, tablo, tir&, i&, j%, r, mem
Set E = [A2:F5] 'tableau des équipes
Set T = [H4:S17] 'tableau à renseigner
nlig = T.Rows.Count: ncol = T.Columns.Count
Application.ScreenUpdating = False
'---initialisations---
For n = 2 To ncol Step 2
T.Columns(n) = "" 'RAZ
Next n
ReDim equip(1 To Application.CountA(E))
n = 0
For Each E In E
If E <> "" Then n = n + 1: equip(n) = E
Next
maxrencontre = Application.RoundUp(nlig * ncol / n / 2, 0)
tablo = T: Randomize
'---tirages aléatoires avec respect des critères 1 et 4---
Do
tir = tir + 1
ReDim compte(1 To n) 'RAZ
For i = 1 To nlig Step 2
For j = 2 To ncol Step 2
1 r = Int(1 + Rnd * n)
If compte(r) = maxrencontre Then GoTo 1
If Not Verif(Left(equip(r), 3)) Then GoTo 3
tablo(i, j) = equip(r): compte(r) = compte(r) + 1
2 r = Int(1 + Rnd * n)
If Left(tablo(i, j), 3) = Left(equip(r), 3) Or _
compte(r) = maxrencontre Then GoTo 2
tablo(i + 1, j) = equip(r): compte(r) = compte(r) + 1
Next j, i
T = tablo
3 Loop While [A7] And tir < ntirages
Application.ScreenUpdating = True
MsgBox tir & IIf(tir = 1, " tirage a suffi...", " tirages ont été nécessaires...")
End Sub
Function Verif(x$) As Boolean
Dim i
For i = 1 To n
If Left(equip(i), 3) <> x And compte(i) < maxrencontre _
Then Verif = True: Exit Function
Next
End Function