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