Option Explicit
Dim MMax As Long, LMax As Long, Tirage() As Long, JoueursManche() As ListeAléat, _
DéjàRenc() As Boolean, DéjàPart() As Boolean, DéjàTêtÀTête() As Boolean
'
Sub Tirage22()
Dim JMax As Long, M As Long, PlgRés As Range, TAff(), _
L As Long, C As Long, Noms()
Rem. ——— Initialisations des conditions de la rencontre.
JMax = Feuil1.[B170].End(xlUp).Row - 5
If JMax Mod 2 = 1 Then
MsgBox "Tirage non applicable pour un nombre impair de participants.", _
vbCritical, "Tirage22": Exit Sub: End If
MMax = IIf(JMax <= 8, 3, 4)
Rem. ——— Initialisations pour le tirage
LMax = (JMax + 2) \ 4
ReDim DéjàRenc(0 To XTria(JMax, JMax - 1)), _
DéjàPart(0 To XTria(JMax, JMax - 1)), _
DéjàTêtÀTête(1 To JMax), JoueursManche(1 To MMax), _
Tirage(1 To MMax, 1 To LMax, 1 To 4)
Randomize
For M = 1 To MMax: Set JoueursManche(M) = New ListeAléat
JoueursManche(M).Init JMax: Next M
Rem. ——— Tirage
If Not RencTrouvée(1, 1) Then MsgBox "Pas de solution trouvée.", vbExclamation, "Tirage22": Exit Sub
Rem. ——— Mise en forme et affichage du résultat
Set PlgRés = Feuil1.[D6:S159]
ReDim TAff(1 To PlgRés.Rows.Count, 1 To PlgRés.Columns.Count)
For L = 1 To LMax: For M = 1 To MMax: For C = 1 To 4
If Tirage(M, L, C) <> 0 Then TAff(L, 4 * (M - 1) + C) = Tirage(M, L, C)
Next C, M, L
PlgRés.Value = TAff
Rem. ——— Mise en forme et affichage pour l'impression
Noms = Feuil1.[B6].Resize(JMax).Value
Set PlgRés = Feuil2.[C8].Resize(320, 23)
ReDim TAff(1 To PlgRés.Rows.Count, 1 To PlgRés.Columns.Count)
For L = 1 To LMax: For M = 1 To MMax: For C = 1 To 4
If Tirage(M, L, C) <> 0 Then
TAff(L * 2 - 1, 6 * (M - 1) + (C * 3 - 1) \ 2) = Tirage(M, L, C)
TAff(L * 2, 6 * (M - 1) + (C * 3 - 1) \ 2) = Noms(Tirage(M, L, C), 1)
End If
Next C, M, L
PlgRés.Value = TAff
PlgRés.Rows.AutoFit 'éventuellement
Feuil2.PageSetup.PrintArea = Feuil2.[C1].Resize(7 + LMax * 2, MMax * 6 - 1).Address
End Sub
'
Private Function RencTrouvée(ByVal M As Long, ByVal L As Long) As Boolean
Dim J1 As Long, PosJ2 As Long, J2 As Long, PosA1 As Long, A1 As Long, PosA2 As Long, A2 As Long, _
xJ1J2 As Long, xJ1A1&, xJ1A2&, xJ2A1&, xJ2A2&, xA1A2&
If L > LMax Then L = 1: M = M + 1: If M > MMax Then RencTrouvée = True: Exit Function
With JoueursManche(M)
If .Count = 2 Then
J1 = .Aléat(1): A1 = .Aléat(2)
If Not (DéjàRenc(XTria(J1, A1)) Or DéjàTêtÀTête(J1) Or DéjàTêtÀTête(A1)) Then
DéjàRenc(XTria(J1, A1)) = True
DéjàTêtÀTête(J1) = True: DéjàTêtÀTête(A1) = True
RencTrouvée = RencTrouvée(M, L + 1) ' C'est en effet une fonction récursive.
If RencTrouvée Then
Tirage(M, L, 2) = J1: Tirage(M, L, 3) = A1
Else
DéjàRenc(XTria(J1, A1)) = False: DéjàTêtÀTête(J1) = False: DéjàTêtÀTête(A1) = False: End If: End If
Exit Function: End If
J1 = .Aléat(1): .Supprimer J1
Do: PosJ2 = PosJ2 + 1: J2 = .Aléat(PosJ2)
If J2 = 0 Then Exit Do
If Not DéjàPart(XTria(J1, J2)) Then
DéjàPart(XTria(J1, J2)) = True
.Supprimer J2
Do: PosA1 = PosA1 + 1: A1 = .Aléat(PosA1)
If A1 = 0 Then Exit Do
If Not (DéjàRenc(XTria(J1, A1)) Or DéjàRenc(XTria(J2, A1))) Then
DéjàRenc(XTria(J1, A1)) = True: DéjàRenc(XTria(J2, A1)) = True
.Supprimer A1
Do: PosA2 = PosA2 + 1: A2 = .Aléat(PosA2)
If A2 = 0 Then Exit Do
If Not (DéjàRenc(XTria(J1, A2)) Or DéjàRenc(XTria(J2, A2)) Or DéjàPart(XTria(A1, A2))) Then
DéjàRenc(XTria(J1, A2)) = True: DéjàRenc(XTria(J2, A2)) = True: DéjàPart(XTria(A1, A2)) = True
.Supprimer A2
RencTrouvée = RencTrouvée(M, L + 1) ' C'est en effet une fonction récursive.
If RencTrouvée Then
Tirage(M, L, 1) = J1: Tirage(M, L, 2) = J2
Tirage(M, L, 3) = A1: Tirage(M, L, 4) = A2
Exit Function: End If
.Remettre A2, PosA2
DéjàRenc(XTria(J1, A2)) = False: DéjàRenc(XTria(J2, A2)) = False: DéjàPart(XTria(A1, A2)) = False
End If: Loop: PosA2 = 0
.Remettre A1, PosA1
DéjàRenc(XTria(J1, A1)) = False: DéjàRenc(XTria(J2, A1)) = False
End If: Loop: PosA1 = 0
.Remettre J2, PosJ2
DéjàPart(XTria(J1, J2)) = False
End If: Loop
.Remettre J1, 1: End With
End Function