Bonjour,
j'organise de plus en plus de tournois sportifs avec 5 équipes de 4 joueurs (total 20) sur 5 ou 6 rencontres.
La contrainte et l'esprit du tournoi est de ne pas faire jouer les mêmes personnes 2 fois au cours des 5 ou 6 rencontres. Jusqu'ici je fais à la main. Mais comme cela devient de plus en plus fréquent et que je suis pris par la préparation du tournoi (logistique, prix, etc.) j'aimerai pourvoir automatiser la génération de la liste des participants.
Les macro trouvée sur internet sur les combinaisons sont très bien. Comme Ce lien n'existe plus ou autres.
Seulement ce que je cherche c'est : j'ai 20 participants et des rencontres de 4 joueurs, donc 5 départs à donner.
Premier jour
A B C D
E F G H
I J K L
L M N O
P Q R S
Deuxième jour
A E I L
P B F J
M Q C G
K N R D
H L O S
Troisième jour
etc.
Cela doit permettre à un joueur de rencontrer tous les autres, peut-être pas tous vu le nombre de combinaisons possibles mais au moins sans rencontrer 2 fois la même personne.
Et si cela est faisable à la main sur 5 jours, cela devient fastidieux sur une année.
Le classement final est basé sur un score individuel vis à vis de tous les adversaires, d'où la nécessité de ne pas rencontrer 2 fois le même concurrent au cours de l'année.
J'ai trouvé une macro VB pour lister des combinaison et permutations que je ne sais pas adapter à mon besoin.
Est-ce que quelqu'un de plus expérimenté pourrait en faire des modifications pour résoudre mon besoin ?
Ou bien me proposer un autre outil.
Si bien sûr il est clairement exprimé.
Merci d'avance
Leonfort
Voici la macro VB dont je vous aiparlé plus haut
'Voici une diabolique procédure pour mettre
'définitivement fin aux questions concernant les
'listes de combinaisons ou de permutations
'de R éléments choisis parmi N.
'Pour l 'utiliser :
'1. En A1, écrire c ou p ; (Combinaison ou Permutation)
'2. En A2, écrire la valeur de R ;
'3. Sous A2, écrire la liste des N éléments ;
'4. Sélectionner A1 et activer la procédure.
'Exemple:
'A1 c
'A2 3
'A3 1
'A4 2
'A5 Excel
'A6 4
'A7 *
'A8 6
'
'La procédure donne alors la liste de toutes les combinaisons
'possibles de 3 éléments choisis parmi 6.
Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub ListPermutations()
Dim Rng As Range
Dim PopSize As Integer
Dim SetSize As Integer
Dim Which As String
Dim N As Double
Const BufferSize As Long = 4096
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then
Set Rng = Range(Rng, Rng.End(xlDown))
End If
PopSize = Rng.Cells.Count - 2
If PopSize < 2 Then GoTo DataError
SetSize = Rng.Cells(2).Value
If SetSize > PopSize Then GoTo DataError
Which = UCase$(Rng.Cells(1).Value)
Select Case Which
Case "C"
N = Application.WorksheetFunction.Combin(PopSize, SetSize)
Case "P"
N = Application.WorksheetFunction.Permut(PopSize, SetSize)
Case Else
GoTo DataError
End Select
If N > Cells.Count Then GoTo DataError
Application.ScreenUpdating = False
Set Results = Worksheets.Add
vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
ReDim Buffer(1 To BufferSize) As String
BufferPtr = 0
If Which = "C" Then
AddCombination PopSize, SetSize
Else
AddPermutation PopSize, SetSize
End If
vAllItems = 0
Application.ScreenUpdating = True
Exit Sub
DataError:
If N = 0 Then
Which = "Enter your data in a vertical range of at least 4 cells. " _
& String$(2, 10) _
& "Top cell must contain the letter C or P, 2nd cell is the number" _
& "of items in a subset, the cells below are the values from which" _
& "the subset is to be chosen."
Else
Which = "This requires " & Format$(N, "#,##0") & _
" cells, more than are available on the worksheet!"
End If
MsgBox Which, vbOKOnly, "DATA ERROR"
Exit Sub
End Sub
Private Sub AddPermutation(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0)
Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Static Used() As Integer
Dim i As Integer
If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
ReDim Used(1 To iPopSize) As Integer
NextMember = 1
End If
For i = 1 To iPopSize
If Used(i) = 0 Then
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
Used(i) = True
AddPermutation , , NextMember + 1
Used(i) = False
Else
SavePermutation SetMembers()
End If
End If
Next i
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
Erase Used
End If
End Sub 'AddPermutation
Private Sub AddCombination(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0, _
Optional NextItem As Integer = 0)
Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Dim i As Integer
If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
NextMember = 1
NextItem = 1
End If
For i = NextItem To iPopSize
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
AddCombination , , NextMember + 1, i + 1
Else
SavePermutation SetMembers()
End If
Next i
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
End If
End Sub 'AddCombination
Private Sub SavePermutation(ItemsChosen() As Integer, _
Optional FlushBuffer As Boolean = False)
Dim i As Integer, sValue As String
Static RowNum As Long, ColNum As Long
If RowNum = 0 Then RowNum = 1
If ColNum = 0 Then ColNum = 1
If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
If BufferPtr > 0 Then
If (RowNum + BufferPtr - 1) > Rows.Count Then
RowNum = 1
ColNum = ColNum + 1
If ColNum > 256 Then Exit Sub
End If
Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
= Application.WorksheetFunction.Transpose(Buffer())
RowNum = RowNum + BufferPtr
End If
BufferPtr = 0
If FlushBuffer = True Then
Erase Buffer
RowNum = 0
ColNum = 0
Exit Sub
Else
ReDim Buffer(1 To UBound(Buffer))
End If
End If
'construct the next set
For i = 1 To UBound(ItemsChosen)
sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
Next i
'and save it in the buffer
BufferPtr = BufferPtr + 1
Buffer(BufferPtr) = Mid$(sValue, 3)
End Sub 'SavePermutation
j'organise de plus en plus de tournois sportifs avec 5 équipes de 4 joueurs (total 20) sur 5 ou 6 rencontres.
La contrainte et l'esprit du tournoi est de ne pas faire jouer les mêmes personnes 2 fois au cours des 5 ou 6 rencontres. Jusqu'ici je fais à la main. Mais comme cela devient de plus en plus fréquent et que je suis pris par la préparation du tournoi (logistique, prix, etc.) j'aimerai pourvoir automatiser la génération de la liste des participants.
Les macro trouvée sur internet sur les combinaisons sont très bien. Comme Ce lien n'existe plus ou autres.
Seulement ce que je cherche c'est : j'ai 20 participants et des rencontres de 4 joueurs, donc 5 départs à donner.
Premier jour
A B C D
E F G H
I J K L
L M N O
P Q R S
Deuxième jour
A E I L
P B F J
M Q C G
K N R D
H L O S
Troisième jour
etc.
Cela doit permettre à un joueur de rencontrer tous les autres, peut-être pas tous vu le nombre de combinaisons possibles mais au moins sans rencontrer 2 fois la même personne.
Et si cela est faisable à la main sur 5 jours, cela devient fastidieux sur une année.
Le classement final est basé sur un score individuel vis à vis de tous les adversaires, d'où la nécessité de ne pas rencontrer 2 fois le même concurrent au cours de l'année.
J'ai trouvé une macro VB pour lister des combinaison et permutations que je ne sais pas adapter à mon besoin.
Est-ce que quelqu'un de plus expérimenté pourrait en faire des modifications pour résoudre mon besoin ?
Ou bien me proposer un autre outil.
Si bien sûr il est clairement exprimé.
Merci d'avance
Leonfort
Voici la macro VB dont je vous aiparlé plus haut
'Voici une diabolique procédure pour mettre
'définitivement fin aux questions concernant les
'listes de combinaisons ou de permutations
'de R éléments choisis parmi N.
'Pour l 'utiliser :
'1. En A1, écrire c ou p ; (Combinaison ou Permutation)
'2. En A2, écrire la valeur de R ;
'3. Sous A2, écrire la liste des N éléments ;
'4. Sélectionner A1 et activer la procédure.
'Exemple:
'A1 c
'A2 3
'A3 1
'A4 2
'A5 Excel
'A6 4
'A7 *
'A8 6
'
'La procédure donne alors la liste de toutes les combinaisons
'possibles de 3 éléments choisis parmi 6.
Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub ListPermutations()
Dim Rng As Range
Dim PopSize As Integer
Dim SetSize As Integer
Dim Which As String
Dim N As Double
Const BufferSize As Long = 4096
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then
Set Rng = Range(Rng, Rng.End(xlDown))
End If
PopSize = Rng.Cells.Count - 2
If PopSize < 2 Then GoTo DataError
SetSize = Rng.Cells(2).Value
If SetSize > PopSize Then GoTo DataError
Which = UCase$(Rng.Cells(1).Value)
Select Case Which
Case "C"
N = Application.WorksheetFunction.Combin(PopSize, SetSize)
Case "P"
N = Application.WorksheetFunction.Permut(PopSize, SetSize)
Case Else
GoTo DataError
End Select
If N > Cells.Count Then GoTo DataError
Application.ScreenUpdating = False
Set Results = Worksheets.Add
vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
ReDim Buffer(1 To BufferSize) As String
BufferPtr = 0
If Which = "C" Then
AddCombination PopSize, SetSize
Else
AddPermutation PopSize, SetSize
End If
vAllItems = 0
Application.ScreenUpdating = True
Exit Sub
DataError:
If N = 0 Then
Which = "Enter your data in a vertical range of at least 4 cells. " _
& String$(2, 10) _
& "Top cell must contain the letter C or P, 2nd cell is the number" _
& "of items in a subset, the cells below are the values from which" _
& "the subset is to be chosen."
Else
Which = "This requires " & Format$(N, "#,##0") & _
" cells, more than are available on the worksheet!"
End If
MsgBox Which, vbOKOnly, "DATA ERROR"
Exit Sub
End Sub
Private Sub AddPermutation(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0)
Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Static Used() As Integer
Dim i As Integer
If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
ReDim Used(1 To iPopSize) As Integer
NextMember = 1
End If
For i = 1 To iPopSize
If Used(i) = 0 Then
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
Used(i) = True
AddPermutation , , NextMember + 1
Used(i) = False
Else
SavePermutation SetMembers()
End If
End If
Next i
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
Erase Used
End If
End Sub 'AddPermutation
Private Sub AddCombination(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0, _
Optional NextItem As Integer = 0)
Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Dim i As Integer
If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
NextMember = 1
NextItem = 1
End If
For i = NextItem To iPopSize
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
AddCombination , , NextMember + 1, i + 1
Else
SavePermutation SetMembers()
End If
Next i
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
End If
End Sub 'AddCombination
Private Sub SavePermutation(ItemsChosen() As Integer, _
Optional FlushBuffer As Boolean = False)
Dim i As Integer, sValue As String
Static RowNum As Long, ColNum As Long
If RowNum = 0 Then RowNum = 1
If ColNum = 0 Then ColNum = 1
If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
If BufferPtr > 0 Then
If (RowNum + BufferPtr - 1) > Rows.Count Then
RowNum = 1
ColNum = ColNum + 1
If ColNum > 256 Then Exit Sub
End If
Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
= Application.WorksheetFunction.Transpose(Buffer())
RowNum = RowNum + BufferPtr
End If
BufferPtr = 0
If FlushBuffer = True Then
Erase Buffer
RowNum = 0
ColNum = 0
Exit Sub
Else
ReDim Buffer(1 To UBound(Buffer))
End If
End If
'construct the next set
For i = 1 To UBound(ItemsChosen)
sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
Next i
'and save it in the buffer
BufferPtr = BufferPtr + 1
Buffer(BufferPtr) = Mid$(sValue, 3)
End Sub 'SavePermutation