Sub Tirage()
Dim Tableau As Variant
Dim Sortie() As String
Dim Boucle As Long, Tourne As Long, Choix As Long
Dim FinLigne As Long, NbElements As Long
Dim Trouve As Boolean, Niveau As Boolean, Sexe As Boolean
FinLigne = Sheets("Participants").Range("A" & Rows.Count).End(xlUp).Row
Tableau = Sheets("Participants").Range("A2:D" & FinLigne)
NbElements = UBound(Tableau, 1)
If NbElements Mod 2 <> 0 Then MsgBox "Nombre de participants incorrect": Exit Sub
For Tourne = 1 To NbElements / 2
Encore:
Boucle = 0
ReDim Sortie(NbElements)
Do
Boucle = Boucle + 1
Do
Choix = Int(Rnd(Timer) * NbElements) + 1
Loop Until Sortie(Choix) = ""
Sortie(Choix) = "*"
If Choix <> Tourne Then
If Tableau(Choix, 4) = "" And (Tableau(Choix, 2) <> Tableau(Tourne, 2) Or Sexe) Then
If Tableau(Choix, 3) <> Tableau(Tourne, 3) Or Niveau Then
Tableau(Choix, 4) = Tourne
Tableau(Tourne, 4) = Choix
Trouve = True
End If
End If
End If
Loop Until Trouve Or Boucle = NbElements
If Boucle = NbElements And Not Niveau Then Niveau = True: GoTo Encore
If Boucle = NbElements And not Sexe Then Sexe = True: GoTo Encore
If Boucle = NbElements then msgbox "Constitution des équipes non résolue"
Trouve = False
With Sheets("equipes")
.Range("A" & Tourne + 1) = "Equipe " & Tourne
.Range("B" & Tourne + 1) = Tableau(Tourne, 1)
.Range("C" & Tourne + 1) = Tableau(Tableau(Tourne, 4), 1)
End With
Next Tourne
End Sub