Round Robin modifié

Le 14/03/2017 à 17:42

Bonjour tout le monde,

je sollicite votre aide afin de finir un script VBA.

J'ai 6 équipes ( nb variable) qui joue 3 fois par semaine (Lundi , Mardi et Mercredi) durant 15 semaines (nb variable), à chaque 5 semaines les équipes rencontrent 1 fois chaque équipe et à chaque 3 semaines toutes les équipes jouent 1 fois le Mardi, chaque équipe joue 5 fois le Lundi , le Mardi et le Mercredi chaque 5 semaines.

J'ai commencé par trouver un code qui donne les combinaisons possibles mais j'ai eu la misère à remplir mon plan ( voir fichier excel ci-joint)

Merci de m'aider si possible.

Cordialement.

21plan.xlsm (18.35 Ko)
Le 14/03/2017 à 19:25

bonsoir,

une proposition, qui se base sur ta mise en page.

Sub aargh()
    a = Range("A2:A7")
    col = 4
    m = 6
    j = 1
    cp = 1
    While j <= 15
        For i = 1 To 3
            cp = cp + 1
            col = col + 2
            If col > 10 Then col = 6: m = m + 1
            If j Mod 2 = 0 Then
                Cells(m, col) = a(i, 1) & " " & a(i + 3, 1)
            Else
                Cells(m, col) = a(i + 3, 1) & " " & a(i, 1)
            End If
            If j <= 10 Then Cells(cp, 4) = Cells(m, col)
        Next i
        Select Case (j Mod 3)
        Case 1
            Range(Cells(m, 6), Cells(m, 10)).Cut Cells(m, 8)
            Cells(m, 12).Cut Cells(m, 6)
        Case 2
            Range(Cells(m, 6), Cells(m, 10)).Cut Cells(m, 10)
            Range(Cells(m, 12), Cells(m, 14)).Cut Cells(m, 6)
        End Select
        y = a(2, 1)
        a(2, 1) = a(3, 1)
        a(3, 1) = a(6, 1)
        a(6, 1) = a(5, 1)
        a(5, 1) = a(4, 1)
        a(4, 1) = y
        j = j + 1
    Wend
    For i = 8 To 18 Step 5
        Cells(i, 6).Cut Cells(i, 7)
    Next i
    Columns("k").Delete shift:=xlToRight
End Sub
Le 14/03/2017 à 20:01

Wow! merci beaucoup.

Pour la condition " À chaque 5 semaines les équipes joue 5 fois" c'est excellent

Il reste juste la condition " À chaque 3 semaines les équipes joue une seule fois le Mardi" voir couleur en rouge.

est ce possible aussi d'ajuster la colonne F, il Ya des données qui se génèrent dans colonne G?

merci infiniment

Excuses je me suis trompé, pour la condition Équipe joue une fois le mardi chaque 3 semaines ne fonctionne pas ( voir mon fichier marqué en rouge)

Merci

13plan.xlsm (20.33 Ko)
10copie-de-plan.xlsm (20.28 Ko)
Le 14/03/2017 à 23:16

re-bonsoir,

ton plan adapté pour correspondre à tes critères (si j'ai bien compris)

15plan.xlsm (16.37 Ko)
Le 14/03/2017 à 23:33

Vous êtes vraiment bon!

J'ai remarqué que le code commences bien, les premières 15 combinaisons sont parfaites pour la condition ( 1 fois chaque Mardi a chaque 3 semaines par équipe ), il nous reste qu'a remplir les autres colonnes Lundi et Mercredi tout en respectant la condition chaque équipe joue une fois par semaine.

merci énormément

h2so4 a écrit :

re-bonsoir,

ton plan adapté pour correspondre à tes critères (si j'ai bien compris)

c'est Excellent ! vous été un génie c'est ça que je veux Wow

Est ce possible de m'envoyer le script modifié? si possible ajouter le nombre d'équipe et nombre semaines comme variables

ça m'arrive souvent d'ajouter une équipe ou semaines exemple : 7 équipes et 20 semaines.

merci infiniment

15plan.xlsm (22.37 Ko)
Le 15/03/2017 à 11:05
rghanmi a écrit :

Est ce possible de m'envoyer le script modifié?

merci infiniment

malheureusement non car je suis parti du résultat donné par le script qui répartit les matches sur 15 semaines, puis j'ai fait manuellement les adaptations pour faire en sorte que chaque équipe ne joue qu'une fois le mardi sur un cycle de 3 semaines.

je n'ai donc pas de script qui donne le résultat que tu souhaites.

Le 15/03/2017 à 11:38

Je te remercie beaucoup pour ton aide!

Il n y a pas un moyen de mettre le nb d'équipe er nb semaines comme nb variables dans le script.

Le reste je peux faire manuellement merci

Le 15/03/2017 à 15:14

re-bonjour,

une version du script adapté pour prendre le nombre d'équipes et le nombre de rencontres en variable.

Sub aargh()
Dim a(100) 'max 100 équipes
    i = 1
    While Cells(i + 1, 1) <> ""
      a(i) = Cells(i + 1, 1)
      i = i + 1
    Wend
    If i Mod 2 = 0 Then
      a(i) = "bye"
      nr = i - 1
    Else
      i = i - 1
      nr = i
    End If
    ne = i
    col = 4
    m = 6: j = 1: cp = 1: s = 1
    ns = CInt(InputBox("nombre de rencontres", , (nr - 1) * 2))
    While s <= ns
        For i = 1 To ne / 2
         cp = cp + 1
         If j Mod 2 = 0 Then
            renc = a(i) & " " & a(ne + 1 - i)
         Else
            renc = a(ne + 1 - i) & " " & a(i)
         End If
         If InStr(a(i) & a(ne + 1 - i), "bye") = 0 Then
            s = s + 1
            col = col + 2
            If col > 10 Then col = 6: m = m + 1
            Cells(m, col) = renc
         End If
         If j <= (nr - 1) * 2 Then Cells(cp, 4) = renc
        Next i
        y = a(2)
        For i = 2 To ne - 1
          a(i) = a(i + 1)
        Next i
        a(ne) = y
        j = j + 1
    Wend
End Sub
Le 15/03/2017 à 18:04

Merci beaucoup! mais ça ne donne pas les mêmes résultats du ton premier script

Le 16/03/2017 à 12:15

bonjour,

ceci devrait donner le même résultat, pour 6 équipes.

Sub aargh()
Dim a(100) 'max 100 équipes
    i = 1
    While Cells(i + 1, 1) <> ""
      a(i) = Cells(i + 1, 1)
      i = i + 1
    Wend
    If i Mod 2 = 0 Then
      a(i) = "bye"
      nr = i - 1
    Else
      i = i - 1
      nr = i
    End If
    ne = i
    col = 4
    m = 6: j = 1: cp = 1: s = 1
    ns = CInt(InputBox("nombre de rencontres", , (nr - 1) * 2))
    While s <= ns
        For i = 1 To ne / 2
         cp = cp + 1
         If j Mod 2 = 0 Then
            renc = a(i) & " " & a(ne + 1 - i)
         Else
            renc = a(ne + 1 - i) & " " & a(i)
         End If
         If InStr(a(i) & a(ne + 1 - i), "bye") = 0 Then
            s = s + 1
            col = col + 2
            If col > 10 Then col = 6: m = m + 1
            Cells(m, col) = renc
         End If
         If j <= (nr - 1) * 2 Then Cells(cp, 4) = renc
        Next i
        If nr Mod 6 = 0 Then
            Select Case (j Mod 3)
            Case 1
                Range(Cells(m, 6), Cells(m, 10)).Cut Cells(m, 8)
                Cells(m, 12).Cut Cells(m, 6)
            Case 2
                Range(Cells(m, 6), Cells(m, 10)).Cut Cells(m, 10)
                Range(Cells(m, 12), Cells(m, 14)).Cut Cells(m, 6)
            End Select
        End If
        y = a(2)
        For i = 2 To ne - 1
          a(i) = a(i + 1)
        Next i
        a(ne) = y
        j = j + 1
    Wend
End Sub
Le 16/03/2017 à 19:23

C'est génial je te remercie beacoup

Rechercher des sujets similaires à "round robin modifie"