Option Explicit
Option Base 1
Dim Z As Byte
Dim TabJ As Variant, Tablo As Variant, TabloC As Variant, TabloR As Variant
Sub TirageParties()
Dim NbJ As Byte, i As Integer, j As Integer, k As Integer, Mypos As String
Dim l As Byte, P As Byte, Lig As Integer, N As Byte
Application.ScreenUpdating = False
Z = Range("A65536").End(xlUp).Row
' Effacement des anciennes données
Union(Range("B2:B2000"), Range("C1:C2000"), Range("D1:IV1000")).ClearContents
' Mise en nombre de joueurs pair
If Z Mod 2 = 0 Then
Z = Z + 1
Cells(Z, 1) = "xxxxxxx"
End If
NbJ = Z - 1
' Tirage aléatoire des joueurs
TirageAleatoire
' Affichage de la liste aléatoire
Range(Cells(2, 2), Cells(Z, 2)) = Tablo
' Tableau des binômes de joueurs
ReDim TabloC(1 To (NbJ * (NbJ - 1)), 1)
' Première boucle pour le nombre de parties
For i = 1 To NbJ - 1
If i = NbJ - 1 Then
Lig = Lig + 1
ElseIf i > 1 Then
Lig = Lig + 2
End If
' Seconde boucle pour les joueurs
For j = i + 1 To NbJ
Lig = Lig + 1
If j = NbJ And i <> NbJ - 1 Then Lig = Lig + i - 1
TabloC(Lig, 1) = Tablo(i, 1) & "-" & Tablo(j, 1)
Next j
Next i
' Mise en tableau du tirage des joueurs
ReDim TabloR(1 To NbJ, 1 To NbJ - 1)
For i = 1 To NbJ
For l = 1 To NbJ - 1
k = k + 1
TabloR(i, l) = TabloC(k, 1)
Next l
Next i
' Nombre choisi de colonne du tableau résultats
N = NbJ - 1
k = 0
'Mise en place des parties
For P = 1 To N
k = k + 1
Cells(1, P + 3) = "PARTIE " & k
Next P
' Affichage des résultats
For i = 1 To NbJ - 1
k = 2
For j = 1 To NbJ ' nombre de lignes du tableau résultats
If TabloR(j, i) <> "" Then
Cells(k, i + 3) = Left(TabloR(j, i), InStr(1, TabloR(j, i), "-") - 1)
Mypos = Len(TabloR(j, i)) - InStr(1, TabloR(j, i), "-")
Cells(k + 1, i + 3) = Right(TabloR(j, i), Mypos)
k = k + 2
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
Sub TirageAleatoire()
Dim j As Integer, k As Integer, T As Byte, X As Byte
Randomize 'Initialisation du générateur de nombres aléatoires
' Mise en mémoire dans un tableau des noms d'équipes
TabJ = Range("A2:A" & Z)
' Déclaration et définition du tableau de la liste aléatoire
ReDim Tablo(1 To UBound(TabJ), 1 To 2)
' Tirage aléatoire des joueurs et mise en tableau de la liste aléatoire
For j = 1 To Z - 1
Do
X = 0
T = Int(((Z - 1) * Rnd) + 1)
Tablo(j, 1) = TabJ(T, 1) ' Mise en colonne aléatoire
For k = 1 To j - 1
If Tablo(j, 1) = Tablo(k, 1) Then
X = 1
Exit For
End If
Next k
Loop Until X = 0
Next j
End Sub
Sub Doublons()
Dim c As Byte, Z As Byte, i As Byte, j As Byte, k As Byte, l As Byte
' Macro enregistrée le 17/04/06 par Gruick
Range("E1").CurrentRegion.Interior.ColorIndex = xlNone
'repèrage des doublons
c = 33
Z = Range("D65536").End(xlUp).Row
For i = 8 To 20 Step 4 'i sera la colonne testée
For k = 4 To i - 1 Step 4 'k sera la colonne comparée
For j = 2 To Z Step 2 'j sera le compteur de ligne de la colonne testée
For l = 2 To Z Step 2 'l sera le compteur de ligne de la colonne comparée
Union(Range(Cells(j, i), Cells(j + 1, i)), Range(Cells(l, k), Cells(l + 1, k))).Select
If (Cells(j, i) = Cells(l, k) And Cells(j + 1, i) = Cells(l + 1, k)) _
Or (Cells(j, i) = Cells(l + 1, k) And Cells(j + 1, i) = Cells(l, k)) Then
Range(Cells(j, i), Cells(j + 1, i)).Interior.ColorIndex = c
Range(Cells(l, k), Cells(l + 1, k)).Interior.ColorIndex = c
c = c + 1
End If
Next l
Next j
Next k
Next i
End Sub
