Passer de 3 a 4 journée en VBA

Bonjour

comment modifier ce code pour passer de 3 à 4 journées

Je vous remercie

Option Explicit

Dim binomes As Object

Sub GenererTournoi()
    Dim joueurs() As Variant
    Dim nbJours As Integer, jour As Integer

    joueurs = ListeJoueurs()
    If Not IsArray(joueurs) Then
        MsgBox "Liste des joueurs invalide ou vide", vbExclamation
        Exit Sub
    End If

    Set binomes = CreateObject("Scripting.Dictionary")

    nbJours = 4 ' nombre de journées

    For jour = 1 To nbJours
        If Not GenererJournee(joueurs, jour) Then
            MsgBox "Impossible de générer la journée " & jour & " sans doublons.", vbExclamation
            Exit For
        End If
    Next jour
End Sub

Function ListeJoueurs() As Variant
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    If lastRow < 3 Then
        ListeJoueurs = Array() ' tableau vide si pas assez de joueurs
    Else
        ListeJoueurs = Application.Transpose(Range("A3:A" & lastRow).Value)
    End If
End Function

Function GenererJournee(joueurs As Variant, journee As Integer) As Boolean
    Dim essaisMax As Long: essaisMax = 25000
    Dim i As Long, reussi As Boolean
    Dim groupes As Collection

    For i = 1 To essaisMax
        Set groupes = GenererGroupes(joueurs)
        If Not GroupesOntDoublons(groupes) Then
            EnregistrerGroupes groupes
            EcrireJournee groupes, journee
            GenererJournee = True
            Exit Function
        End If
    Next i

    GenererJournee = False ' aucun tirage valide trouvé
End Function

Function GenererGroupes(joueurs As Variant) As Collection
    Dim temp() As Variant
    Dim i As Long, j As Long
    Dim n As Long
    Dim baseIndex As Long

    ' Copie des joueurs dans un tableau 1D temp()
    If IsArray(joueurs) Then
        temp = joueurs
    Else
        temp = Array(joueurs)
    End If

    ' Gérer base 1 ou 0
    baseIndex = LBound(temp)
    n = UBound(temp) - baseIndex + 1

    Call MelangerTableau(temp)

    Set GenererGroupes = New Collection
    i = baseIndex

    Do While i + 3 <= UBound(temp)
        Dim groupe(0 To 3) As String
        For j = 0 To 3
            groupe(j) = temp(i + j)
        Next j
        GenererGroupes.Add groupe
        i = i + 4
    Loop
End Function

Sub MelangerTableau(tableau As Variant)
    Dim i As Long, j As Long
    Dim tempVal As Variant
    Randomize
    For i = UBound(tableau) To LBound(tableau) + 1 Step -1
        j = Int((i - LBound(tableau) + 1) * Rnd + LBound(tableau))
        tempVal = tableau(i)
        tableau(i) = tableau(j)
        tableau(j) = tempVal
    Next i
End Sub

Function GroupesOntDoublons(groupes As Collection) As Boolean
    Dim g As Variant, i As Long, j As Long
    Dim cle As String

    For Each g In groupes
        For i = 0 To 3
            For j = i + 1 To 3
                cle = CleBinome(g(i), g(j))
                If binomes.exists(cle) Then
                    GroupesOntDoublons = True
                    Exit Function
                End If
            Next j
        Next i
    Next g

    GroupesOntDoublons = False
End Function

Sub EnregistrerGroupes(groupes As Collection)
    Dim g As Variant
    Dim i As Long, j As Long
    Dim joueur1 As String, joueur2 As String
    For Each g In groupes
        If IsArray(g) Then
            For i = LBound(g) To UBound(g)
                For j = i + 1 To UBound(g)
                    joueur1 = g(i)
                    joueur2 = g(j)
                    binomes(CleBinome(joueur1, joueur2)) = True
                Next j
            Next i
        End If
    Next g
End Sub
Sub EcrireJournee(groupes As Collection, journee As Integer)
    Dim colStart As Integer: colStart = 4 ' colonne D
    Dim ligneStart As Integer: ligneStart = 1 + (journee - 1) * 6

    ' En-tête fusionnée
    With Range(Cells(ligneStart, colStart), Cells(ligneStart, colStart + groupes.Count - 1))
        .Merge
        .Value = "Journée " & journee
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
    End With

    ' Numéros de poule
    Dim i As Long
    For i = 0 To groupes.Count - 1
        Cells(ligneStart + 1, colStart + i).Value = "POULE " & (i + 1)
        Cells(ligneStart + 1, colStart + i).HorizontalAlignment = xlCenter
    Next i

    ' Insertion des joueurs
    Dim g As Variant, j As Long
    For i = 0 To groupes.Count - 1
        g = groupes(i + 1)
        For j = 0 To 3
            Cells(ligneStart + 2 + j, colStart + i).Value = g(j)
        Next j
    Next i
End Sub
Function CleBinome(ByVal a As Variant, ByVal b As Variant) As String
    Dim sa As String, sb As String
    sa = CStr(a)
    sb = CStr(b)
    If sa < sb Then
        CleBinome = sa & "-" & sb
    Else
        CleBinome = sb & "-" & sa
    End If
End Function

Salut Joco7915

Comme ça et sans fichier

Bonsoir

ci-joint le fichier

re,

3 est facile, 4 est un peu plus difficile, 5 est avec beaucoup de chance, je suppose.

Bonjour Bart

Merci pour ton aide

Ton fichier st bien mais pour avoir un résultat la machine mouline sérieusement.

Cordialement

bonjour Joco7915,

ce que tu vois, c'est le meilleur résultat après 50 tentatives (environ 1 solution par seconde)

Voir la plage N1:O6, on peut y voir par exemple qu'on a 7 solutions sur 50 avec 3 journées complètes et 1 solution avec 4 journées complètes. (chaque fois des autres chiffres)

Donc c'est beaucoup de "trial and error" pour y arriver ...

PS. si chaque couple peut exister en 2 formes, une fois comme adversaires et l'autre fois comme un team, cela augmente le nombre de journées possibles !