Const ntirages = 10000 'nombre maximum de tirages
Dim n&, equip$(), DicoCrit2 As Object, DicoCrit4 As Object, compte() As Boolean
Sub Tirages()
Dim E As Range, i&, T As Range, j%, tablo, tir&, r1, x1$, r2, x2$, y$, k&
Set E = [A1].CurrentRegion.Offset(1) 'tableau des équipes
Application.ScreenUpdating = False
'---initialisations---
n = 2 * Int(Application.CountA(E) / 2) 'nombre pair
ReDim equip(1 To n, 1 To 5)
For Each E In E
If E <> "" And i < n Then i = i + 1: equip(i, 1) = E
Next
Set T = [H4].Resize(n, 8) 'tableau à renseigner
For j = 2 To 8 Step 2
T.Columns(j).Resize(1000) = "" 'RAZ
Next j
Set DicoCrit2 = CreateObject("Scripting.Dictionary")
Set DicoCrit4 = CreateObject("Scripting.Dictionary")
tablo = T: Randomize
'---tirages aléatoires avec respect des 4 critères---
1 If tir < ntirages Then
tir = tir + 1
DicoCrit2.RemoveAll: DicoCrit4.RemoveAll 'RAZ
For j = 2 To 8 Step 2
ReDim compte(1 To n) 'RAZ
For i = 1 To n Step 2
2 r1 = Int(1 + Rnd * n)
If compte(r1) Then GoTo 2
x1 = equip(r1, 1): compte(r1) = True
If Not Verif(x1) Then GoTo 1
3 r2 = Int(1 + Rnd * n)
x2 = equip(r2, 1)
y = IIf(x1 < x2, x1 & x2, x2 & x1)
If Left(x1, 3) = Left(x2, 3) Or DicoCrit2.exists(y) Or _
DicoCrit4.exists(x1 & Left(x2, 3)) Or DicoCrit4.exists(x2 & Left(x1, 3)) _
Or compte(r2) Then GoTo 3
DicoCrit2(y) = ""
DicoCrit4(x1 & Left(x2, 3)) = "": DicoCrit4(x2 & Left(x1, 3)) = ""
tablo(i, j) = x1: tablo(i + 1, j) = x2: compte(r2) = True
Next i, j
End If
'---restitution---
T = tablo
tablo = DicoCrit2.keys
For i = 1 To n
j = 2
For k = 0 To UBound(tablo)
If InStr(tablo(k), equip(i, 1)) Then _
equip(i, j) = Replace(tablo(k), equip(i, 1), ""): j = j + 1
Next k, i
With Range("A19:E" & Rows.Count)
.ClearContents
.Resize(n) = equip
.Sort .Columns(1), Header:=xlNo 'tri
End With
Application.ScreenUpdating = True
MsgBox tir & IIf(tir = 1, " tirage a suffi...", " tirages ont été nécessaires...")
End Sub
Function Verif(x1$) As Boolean
Dim i&, x2$, y$
For i = 1 To n
x2 = equip(i, 1)
y = IIf(x1 < x2, x1 & x2, x2 & x1)
If Left(x1, 3) <> Left(x2, 3) And Not DicoCrit2.exists(y) And _
Not DicoCrit4.exists(x1 & Left(x2, 3)) And Not DicoCrit4.exists(x2 & Left(x1, 3)) _
And Not compte(i) Then Verif = True: Exit Function
Next
End Function