Option Explicit
Sub Répartir()
Dim Pl As Range, PlNom As Range, PlAsso As Range
Dim tNom(), tAsso()
Dim tPouleNom(), tPouleAsso()
Dim tNomAPlacer(), tAssoAPlacer()
Dim i As Long, j As Long, NumNom As Byte, Der_Poule_ligne As Byte
Dim Ligne As Byte, NumPoule As Byte, NbPoule As Byte
Dim NbNomTraité As Byte, PouleRef As Byte, NbNomAPlacer As Byte
Dim MêmeAsso As Boolean
Dim DernJoueur As Long, DernPoule As Byte, DernlLigne As Byte
Range("I1:T100").ClearContents
Set Pl = Range("A1").CurrentRegion
Set PlNom = Pl.Columns(2) 'plage du nom des joueurs
Set PlAsso = Pl.Columns(4) 'plage du nom des associations
tNom = PlNom.Value 'stockage de la plage du nom des joueurs dans un Array
tAsso = PlAsso.Value 'stockage de la plage du nom des associations dans un Array
DernJoueur = PlNom.Rows.Count
DernPoule = Range("Nb_poule").Value
DernlLigne = Application.WorksheetFunction.RoundUp(DernJoueur / DernPoule, 0)
ReDim tPouleNom(1 To DernPoule, 1 To DernlLigne)
ReDim tPouleAsso(1 To DernPoule, 1 To DernlLigne)
ReDim tNomAPlacer(1 To DernPoule)
ReDim tAssoAPlacer(1 To DernPoule)
NumNom = 1
For Ligne = 1 To DernlLigne
If Ligne = 1 Then
For i = 1 To DernPoule
tPouleNom(i, 1) = tNom(i, 1)
tPouleAsso(i, 1) = tAsso(i, 1)
NumNom = NumNom + 1
Next i
Else
If Ligne Mod 2 = 0 Then NumPoule = DernPoule Else NumPoule = 1
Der_Poule_ligne = NumPoule
NbNomTraité = 0
For i = 1 To DernPoule
If NumNom <= DernJoueur Then
tNomAPlacer(i) = tNom(NumNom, 1)
tAssoAPlacer(i) = tAsso(NumNom, 1)
NumNom = NumNom + 1
End If
Next i
For i = 1 To UBound(tNomAPlacer)
If tNomAPlacer(i) <> vbNullString Then
MêmeAsso = False
If tPouleAsso(NumPoule, Ligne) = vbNullString Then
For j = 1 To Ligne - 1
If tPouleAsso(NumPoule, j) = tAssoAPlacer(i) Then
MêmeAsso = True
Exit For
End If
Next j
If MêmeAsso = False Then
tPouleNom(NumPoule, Ligne) = tNomAPlacer(i)
tPouleAsso(NumPoule, Ligne) = tAssoAPlacer(i)
tNomAPlacer(i) = vbNullString
tAssoAPlacer(i) = vbNullString
NbNomTraité = NbNomTraité + 1
NumPoule = Der_Poule_ligne
Else
i = i - 1
If Ligne Mod 2 = 0 Then NumPoule = NumPoule - 1 Else NumPoule = NumPoule + 1
If NumPoule = DernPoule + 1 Or NumPoule = 0 Then
NumPoule = Der_Poule_ligne
i = i + 1
End If
End If
Else
i = i - 1
If Ligne Mod 2 = 0 Then NumPoule = NumPoule - 1 Else NumPoule = NumPoule + 1
'si toutes les poules ont été testées on initialise le compteur de poule et on passe au nom suivant
If NumPoule = 0 Then NumPoule = DernPoule: i = i + 1
If NumPoule = DernPoule + 1 Then NumPoule = 1: i = i + 1
'If NumPoule = 0 Or NumPoule = DernPoule + 1 Then Exit For
End If
End If
Next i
'traitement des noms non placés s'il en reste
If NbNomTraité < DernPoule Then
For i = 1 To DernPoule
'recherche de la 1ère poule qui n'a pas une asso renseignée dans la ligne traitée
NumPoule = Poule_de_reference(tPouleAsso(), Ligne): PouleRef = NumPoule
If tPouleAsso(NumPoule, Ligne) = vbNullString Then
For NbNomAPlacer = 1 To UBound(tNomAPlacer)
If tNomAPlacer(NbNomAPlacer) <> vbNullString Then
For NbPoule = 1 To DernPoule
For j = 1 To Ligne
MêmeAsso = False
' If tPouleAsso(NumPoule, j) = tAssoAPlacer(NbNomAPlacer) Then
If tPouleAsso(NumPoule, j) = tAssoAPlacer(NbNomAPlacer) Or _
tPouleAsso(PouleRef, j) = tPouleAsso(NumPoule, Ligne) Then
MêmeAsso = True
Exit For
End If
Next j
If MêmeAsso = False Then Exit For
If Ligne Mod 2 = 0 Then NumPoule = NumPoule + 1 Else NumPoule = NumPoule - 1
If NumPoule = 0 Or NumPoule = DernPoule + 1 Then Exit For
Next NbPoule
'si une poule ne contenant pas la même association est trouvée on la renseigne
If MêmeAsso = False Then
tPouleNom(PouleRef, Ligne) = tPouleNom(NumPoule, Ligne)
tPouleAsso(PouleRef, Ligne) = tPouleAsso(NumPoule, Ligne)
tPouleNom(NumPoule, Ligne) = tNomAPlacer(NbNomAPlacer)
tPouleAsso(NumPoule, Ligne) = tAssoAPlacer(NbNomAPlacer)
tNomAPlacer(NbNomAPlacer) = vbNullString
tAssoAPlacer(NbNomAPlacer) = vbNullString
NbNomTraité = NbNomTraité + 1
'sinon on place la paire nom/asso dans la poule de référence
Else
tPouleNom(PouleRef, Ligne) = tNomAPlacer(NbNomAPlacer)
tPouleAsso(PouleRef, Ligne) = tAssoAPlacer(NbNomAPlacer)
tNomAPlacer(NbNomAPlacer) = vbNullString
tAssoAPlacer(NbNomAPlacer) = vbNullString
NbNomTraité = NbNomTraité + 1
End If
If NbNomTraité = UBound(tNomAPlacer) Then Exit For 'si tous les noms sont placés on sort
's'il existe encore un nom non placé on recalcule la poule de référence
NumPoule = Poule_de_reference(tPouleAsso(), Ligne): PouleRef = NumPoule
End If
Next NbNomAPlacer
End If
If NbNomTraité = UBound(tNomAPlacer) Then Exit For
If Ligne Mod 2 = 0 Then NumPoule = NumPoule + 1 Else NumPoule = NumPoule - 1
Next i
End If
End If
'on lance la procédure permettant d'équilibrer les poules
If Ligne > 2 Then Call Equilibrer_poule(tPouleNom(), tPouleAsso(), Ligne, DernPoule)
Next Ligne
'report du tableau des joueurs
Range("I1").Resize(UBound(tPouleNom, 2), UBound(tPouleNom, 1)) = Application.Transpose(tPouleNom)
'report du tableau des associations (uniquement pour contrôler)
Range("I21").Resize(UBound(tPouleAsso, 2), UBound(tPouleAsso, 1)) = Application.Transpose(tPouleAsso)
End Sub
'Ce code est lancé à chaque ligne à partir de la ligne 3.
'Il permet de vérifier l'équilibre de la répartition des associations dans les poules.
Sub Equilibrer_poule(tPouleNom(), tPouleAsso(), Ligne As Byte, DernPoule As Byte)
Dim i As Long, j As Long, k As Byte, l As Byte
Dim NbAsso As Byte, tempNom As String, tempAsso As String
Dim tTemp(), FinTraitement As Boolean
Dim NbAssoPouleRef As Byte, NbAssoRef As Byte
'Dans chaque poules on compte le nombre de fois où l'asso de la dernière ligne est déjà présente dans la poule.
'Si cette asso est déjà présente au minimum 2 fois on stocke dans un tableau temporaire le nom de l'asso,
'le n° de la poule et le nombre de fois où elle est déjà présente dans cette poule.
For i = 1 To DernPoule
NbAsso = 0
For j = 1 To Ligne - 1
If tPouleAsso(i, Ligne) = tPouleAsso(i, j) Then
NbAsso = NbAsso + 1
End If
Next j
If NbAsso >= 2 Then
k = k + 1
ReDim Preserve tTemp(1 To 3, 1 To k)
tTemp(1, k) = tPouleAsso(i, Ligne) 'nom de l'asso placée à la dernière ligne de la poule
tTemp(2, k) = i 'n° de la poule
tTemp(3, k) = NbAsso 'nombre de fois où l'asso est déjà présente dans la poule
End If
Next i
NbAsso = 0
'Si le tableau comporte au moins 1 association on lance la partie qui suit
If k > 0 Then
'On traite les associations stockées dans le tableau dans l'ordre indiqué par le sens du serpent :
'- en commençant par la 1ère asso si l'on traite une ligne impaire
'- en commençant par la dernière asso si l'on traite une ligne paire
For i = IIf(Ligne Mod 2 <> 0, 1, UBound(tTemp, 2)) To IIf(Ligne Mod 2 <> 0, _
UBound(tTemp, 2), 1) Step IIf(Ligne Mod 2 <> 0, 1, -1)
'on traite les poules stockées dans l'ordre indiqué par le sens du serpent :
'- en commençant par la 1ère poule si l'on traite une ligne impaire
'- en commençant par la dernière poule si l'on traite une ligne paire
'
'A chaque rotation on compare donc la poule testée dans cette rotation
'avec la poule où se trouve l'asso redondante stockée dans le tableau (appelée "poule de référence")
For j = IIf(Ligne Mod 2 <> 0, 1, DernPoule) To IIf(Ligne Mod 2 <> 0, DernPoule, 1) _
Step IIf(Ligne Mod 2 <> 0, 1, -1)
NbAsso = 0: NbAssoPouleRef = 0: NbAssoRef = 0
If tTemp(2, i) <> j Then
If tPouleAsso(j, Ligne) <> tTemp(1, i) Then
'On compte le nombre de fois où l'asso répertoriée dans le tableau
'est présente dans la poule testée
For l = 1 To Ligne
If tPouleAsso(j, l) = tTemp(1, i) Then
NbAsso = NbAsso + 1
End If
'On compte le nombre de fois où l'asso de la ligne
'de la poule testée est présente dans la poule de référence
If tPouleAsso(tTemp(2, i), l) = tPouleAsso(j, Ligne) Then
NbAssoPouleRef = NbAssoPouleRef + 1
End If
'On compte le nombre de fois où l'asso de la ligne de la poule testée
'existe déjà dans cette même poule
If tPouleAsso(j, l) = tPouleAsso(j, Ligne) Then
NbAssoRef = NbAssoRef + 1
End If
If l = Ligne Then FinTraitement = True 'quand toutes les lignes de la poule sont testées on passe à la suite
Next l
'La suite du traitement dépend des critères de modification que l'on se fixe pour permuter la place de l'asso
'placée dans la poule testée avec celle placée dans la poule de référence (stockée dans le tableau temporaire) :
'1)si l'on autorise la permutation à partir du moment où le nombre de présence de l'asso présente dans la poule testée
'est inférieur à 2 la condition choisie est "If NbAsso < 2 Then"
'2)si l'on autorise la permutation à partir du moment où le nombre de présence de l'asso présente dans la poule testée
'est inférieur à celui de la poule de référence la condition choisie est "If NbAsso < tTemp(3, i) Then"
'3)Si l'on ajoute au critère 2 le fait de n'autoriser la permutation que si l'asso de la poule testée est également moins
'présente dans la poule de référence on choisit comme condition
'"If NbAsso < tTemp(3, i) And NbAssoPouleRef <= NbAssoRef Then"
If FinTraitement = True Then
FinTraitement = False
'If NbAsso < 2 Then
If NbAsso < tTemp(3, i) Then
'If NbAsso < tTemp(3, i) And NbAssoPouleRef <= NbAssoRef Then
tempNom = tPouleNom(tTemp(2, i), Ligne)
tempAsso = tPouleAsso(tTemp(2, i), Ligne)
tPouleNom(tTemp(2, i), Ligne) = tPouleNom(j, Ligne)
tPouleAsso(tTemp(2, i), Ligne) = tPouleAsso(j, Ligne)
tPouleNom(j, Ligne) = tempNom
tPouleAsso(j, Ligne) = tempAsso
Exit For
End If
End If
End If
End If
Next j
Next i
End If
End Sub
Function Poule_de_reference(tPouleAsso(), Ligne As Byte) As Byte
Dim j As Long
For j = IIf(Ligne Mod 2 <> 0, 1, UBound(tPouleAsso)) To _
IIf(Ligne Mod 2 <> 0, UBound(tPouleAsso), 1) Step IIf(Ligne Mod 2 <> 0, 1, -1)
If tPouleAsso(j, Ligne) = vbNullString Then
Poule_de_reference = j: Exit For
End If
Next
End Function
!
