Option Explicit
Sub Tirage()
Dim Tablo, temp
Dim i As Integer, j As Long, k As Integer, L As Byte
Dim NbJ As Integer
Dim Nb3 As Long
Dim Nb2 As Long
Dim Num As Long
Dim Cl As Integer
Dim NbManche As Byte
'Stop
With Sheets("Liste")
'.Unprotect
Tablo = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
NbJ = UBound(Tablo)
'Affichage du tableau dans l'onglet Recap
With Sheets("Recap")
.Unprotect
.Range("B3:B100").ClearContents
For i = 1 To NbJ
.Cells(i + 2, 2) = Tablo(i, 1)
Next i
.Protect
End With
Select Case NbJ Mod 3 ' Multiple de 3 ?
Case 0
If (NbJ / 3) Mod 2 > 0 Then ' Nombre équipe impair
Nb3 = (NbJ / 3) - 2
Nb2 = 3
Else
Nb3 = NbJ / 3
Nb2 = 0
End If
Case 1
If ((NbJ \ 3) - 1) Mod 2 = 0 Then ' 1 équipe de 3 en moins = nombre pair
Nb3 = (NbJ \ 3) - 1
Nb2 = 2
Else
Nb3 = (NbJ \ 3) - 3
Nb2 = 5
End If
Case 2
If (NbJ \ 3) Mod 2 = 0 Then ' Nombre équipe de 3 pair
Nb3 = (NbJ \ 3) - 2
Nb2 = 4
Else
Nb3 = (NbJ \ 3)
Nb2 = 1
End If
End Select
' On efface tous les tableaux
For L = 1 To 5
Sheets("P" & L).Range("A4:F12").ClearContents
Sheets("P" & L).Range("G4:H12") = 0
Next L
Randomize
ReDim Preserve Tablo(1 To UBound(Tablo, 1), 1 To UBound(Tablo, 2) + 1)
If UserForm1.OptionButtonManche3 = True Then NbManche = 3
If UserForm1.OptionButtonManche4 = True Then NbManche = 4
If UserForm1.OptionButtonManche5 = True Then NbManche = 5
For L = 1 To NbManche
' Numérotation aléatoire des joueurs
For i = 1 To UBound(Tablo, 1)
Tablo(i, UBound(Tablo, 2)) = Rnd
Next i
' Tri en fonction du numérotage
For i = 1 To UBound(Tablo, 1)
For j = 1 To UBound(Tablo, 1)
If Tablo(i, UBound(Tablo, 2)) > Tablo(j, UBound(Tablo, 2)) Then
For k = 1 To UBound(Tablo, 2)
temp = Tablo(i, k)
Tablo(i, k) = Tablo(j, k)
Tablo(j, k) = temp
Next k
End If
Next j
Next i
With Sheets("P" & L)
.Range("A4:H12").ClearContents
.Range("C14") = Format(Date, "DD-MM-YYYY")
j = 4 ' 1ère ligne
Cl = 1
Num = 0
For i = 1 To Nb3 ' Pour toutes les triplettes
For k = 0 To 2 ' Pour 3 joueurs
Num = Num + 1 ' Indice dans le tableau : Tablo
.Cells(j, Cl) = Tablo(Num, 1)
Cl = Cl + 1
If Cl = 7 Then
Cl = 1
j = j + 1
End If
Next k
Next i
For i = 1 To Nb2 ' Pour toutes les doublettes
For k = 0 To 1 ' Pour 2 joueurs
Num = Num + 1 ' Indice dans le tableau : Tablo
.Cells(j, Cl) = Tablo(Num, 1)
Cl = Cl + 1
If Cl = 3 Then
Cl = 4
ElseIf Cl = 6 Then
Cl = 1
j = j + 1
End If
Next k
Next i
.Columns("A:H").AutoFit
End With
Next L
Application.ScreenUpdating = True
End Sub
