Salut Françoise,
La procédure donne la liste de toutes les combinaisons
possibles de 5 canassons parmi les 18 partants:
8568 combinaisons
'Voici une diabolique procédure de Myrna Larson 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 (C dans ton cas)
'2. En A2, écrire la valeur de r (5 pour quinté)
'3. En A3:A20, écrire la liste des partants
'4. Sélectionner A1 et activer la procédure : ListPermutations()
'Exemple:
'A1 c
'A2 5
'A3 1
'A4 2
'A5 3
'A7 4
'A8 5
'A9 6
'...
'A20 18
Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub ListPermutations()
Const BufferSize As Long = 4096
Dim Rng As Range, PopSize As Integer
Dim N As Double, SetSize As Integer, Which As String
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then Set Rng = Range(Rng, Rng.End(xlDown))
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
Results.Move before:=Worksheets(1)
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"
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
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
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
--
Amicalement
Jean-François Aubert
{Vaudois de la Côte Lémanique}
"Françoise" a écrit dans le message de
news:bkpt8s$iu4$Bonsoir,
Encore une fois j'ai besoin de votre aide et je vous en remercie. On m'a
posé une colle et je ne trouve pas la solution. La personne voudrait
calculer les probabilités pour un quinté. On a par exemple 18 chevaux et
on
voudrait afficher toutes les combinaisons possibles. Cela fait 1 028 160
alors qu'il y a seulement 65536 lignes sur Excel. 1ère question : Est-ce
possible ? Si cela ne l'est pas pourrait-on le faire pour un quarté,
cela
ferait seulement 73440 combinaisons possibles. 2ème question : Si on
peut
afficher toutes les combinaisons, comment faire pour ne garder qu'une
probabilité en éliminant les mêmes qui sont dans un ordre différent ?
Salut Françoise,
La procédure donne la liste de toutes les combinaisons
possibles de 5 canassons parmi les 18 partants:
8568 combinaisons
'Voici une diabolique procédure de Myrna Larson 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 (C dans ton cas)
'2. En A2, écrire la valeur de r (5 pour quinté)
'3. En A3:A20, écrire la liste des partants
'4. Sélectionner A1 et activer la procédure : ListPermutations()
'Exemple:
'A1 c
'A2 5
'A3 1
'A4 2
'A5 3
'A7 4
'A8 5
'A9 6
'...
'A20 18
Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub ListPermutations()
Const BufferSize As Long = 4096
Dim Rng As Range, PopSize As Integer
Dim N As Double, SetSize As Integer, Which As String
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then Set Rng = Range(Rng, Rng.End(xlDown))
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
Results.Move before:=Worksheets(1)
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"
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
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
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
--
Amicalement
Jean-François Aubert
{Vaudois de la Côte Lémanique}
"Françoise" <f.jeandesbo@wanadoo.fr> a écrit dans le message de
news:bkpt8s$iu4$1@news-reader5.wanadoo.fr...
Bonsoir,
Encore une fois j'ai besoin de votre aide et je vous en remercie. On m'a
posé une colle et je ne trouve pas la solution. La personne voudrait
calculer les probabilités pour un quinté. On a par exemple 18 chevaux et
on
voudrait afficher toutes les combinaisons possibles. Cela fait 1 028 160
alors qu'il y a seulement 65536 lignes sur Excel. 1ère question : Est-ce
possible ? Si cela ne l'est pas pourrait-on le faire pour un quarté,
cela
ferait seulement 73440 combinaisons possibles. 2ème question : Si on
peut
afficher toutes les combinaisons, comment faire pour ne garder qu'une
probabilité en éliminant les mêmes qui sont dans un ordre différent ?
Salut Françoise,
La procédure donne la liste de toutes les combinaisons
possibles de 5 canassons parmi les 18 partants:
8568 combinaisons
'Voici une diabolique procédure de Myrna Larson 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 (C dans ton cas)
'2. En A2, écrire la valeur de r (5 pour quinté)
'3. En A3:A20, écrire la liste des partants
'4. Sélectionner A1 et activer la procédure : ListPermutations()
'Exemple:
'A1 c
'A2 5
'A3 1
'A4 2
'A5 3
'A7 4
'A8 5
'A9 6
'...
'A20 18
Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub ListPermutations()
Const BufferSize As Long = 4096
Dim Rng As Range, PopSize As Integer
Dim N As Double, SetSize As Integer, Which As String
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then Set Rng = Range(Rng, Rng.End(xlDown))
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
Results.Move before:=Worksheets(1)
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"
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
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
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
--
Amicalement
Jean-François Aubert
{Vaudois de la Côte Lémanique}
"Françoise" a écrit dans le message de
news:bkpt8s$iu4$Bonsoir,
Encore une fois j'ai besoin de votre aide et je vous en remercie. On m'a
posé une colle et je ne trouve pas la solution. La personne voudrait
calculer les probabilités pour un quinté. On a par exemple 18 chevaux et
on
voudrait afficher toutes les combinaisons possibles. Cela fait 1 028 160
alors qu'il y a seulement 65536 lignes sur Excel. 1ère question : Est-ce
possible ? Si cela ne l'est pas pourrait-on le faire pour un quarté,
cela
ferait seulement 73440 combinaisons possibles. 2ème question : Si on
peut
afficher toutes les combinaisons, comment faire pour ne garder qu'une
probabilité en éliminant les mêmes qui sont dans un ordre différent ?
Salut Françoise,
La procédure donne la liste de toutes les combinaisons
possibles de 5 canassons parmi les 18 partants:
8568 combinaisons
'Voici une diabolique procédure de Myrna Larson 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 (C dans ton cas)
'2. En A2, écrire la valeur de r (5 pour quinté)
'3. En A3:A20, écrire la liste des partants
'4. Sélectionner A1 et activer la procédure : ListPermutations()
'Exemple:
'A1 c
'A2 5
'A3 1
'A4 2
'A5 3
'A7 4
'A8 5
'A9 6
'...
'A20 18
Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub ListPermutations()
Const BufferSize As Long = 4096
Dim Rng As Range, PopSize As Integer
Dim N As Double, SetSize As Integer, Which As String
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then Set Rng = Range(Rng, Rng.End(xlDown))
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
Results.Move before:=Worksheets(1)
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"
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
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
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
--
Amicalement
Jean-François Aubert
{Vaudois de la Côte Lémanique}
"Françoise" a écrit dans le message de
news:bkpt8s$iu4$Bonsoir,
Encore une fois j'ai besoin de votre aide et je vous en remercie. On m'a
posé une colle et je ne trouve pas la solution. La personne voudrait
calculer les probabilités pour un quinté. On a par exemple 18 chevaux et
on
voudrait afficher toutes les combinaisons possibles. Cela fait 1 028 160
alors qu'il y a seulement 65536 lignes sur Excel. 1ère question : Est-ce
possible ? Si cela ne l'est pas pourrait-on le faire pour un quarté,
cela
ferait seulement 73440 combinaisons possibles. 2ème question : Si on
peut
afficher toutes les combinaisons, comment faire pour ne garder qu'une
probabilité en éliminant les mêmes qui sont dans un ordre différent ?
Salut Françoise,
La procédure donne la liste de toutes les combinaisons
possibles de 5 canassons parmi les 18 partants:
8568 combinaisons
'Voici une diabolique procédure de Myrna Larson 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 (C dans ton cas)
'2. En A2, écrire la valeur de r (5 pour quinté)
'3. En A3:A20, écrire la liste des partants
'4. Sélectionner A1 et activer la procédure : ListPermutations()
'Exemple:
'A1 c
'A2 5
'A3 1
'A4 2
'A5 3
'A7 4
'A8 5
'A9 6
'...
'A20 18
Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub ListPermutations()
Const BufferSize As Long = 4096
Dim Rng As Range, PopSize As Integer
Dim N As Double, SetSize As Integer, Which As String
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then Set Rng = Range(Rng, Rng.End(xlDown))
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
Results.Move before:=Worksheets(1)
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"
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
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
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
--
Amicalement
Jean-François Aubert
{Vaudois de la Côte Lémanique}
"Françoise" <f.jeandesbo@wanadoo.fr> a écrit dans le message de
news:bkpt8s$iu4$1@news-reader5.wanadoo.fr...
Bonsoir,
Encore une fois j'ai besoin de votre aide et je vous en remercie. On m'a
posé une colle et je ne trouve pas la solution. La personne voudrait
calculer les probabilités pour un quinté. On a par exemple 18 chevaux et
on
voudrait afficher toutes les combinaisons possibles. Cela fait 1 028 160
alors qu'il y a seulement 65536 lignes sur Excel. 1ère question : Est-ce
possible ? Si cela ne l'est pas pourrait-on le faire pour un quarté,
cela
ferait seulement 73440 combinaisons possibles. 2ème question : Si on
peut
afficher toutes les combinaisons, comment faire pour ne garder qu'une
probabilité en éliminant les mêmes qui sont dans un ordre différent ?
Salut Françoise,
La procédure donne la liste de toutes les combinaisons
possibles de 5 canassons parmi les 18 partants:
8568 combinaisons
'Voici une diabolique procédure de Myrna Larson 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 (C dans ton cas)
'2. En A2, écrire la valeur de r (5 pour quinté)
'3. En A3:A20, écrire la liste des partants
'4. Sélectionner A1 et activer la procédure : ListPermutations()
'Exemple:
'A1 c
'A2 5
'A3 1
'A4 2
'A5 3
'A7 4
'A8 5
'A9 6
'...
'A20 18
Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub ListPermutations()
Const BufferSize As Long = 4096
Dim Rng As Range, PopSize As Integer
Dim N As Double, SetSize As Integer, Which As String
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then Set Rng = Range(Rng, Rng.End(xlDown))
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
Results.Move before:=Worksheets(1)
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"
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
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
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
--
Amicalement
Jean-François Aubert
{Vaudois de la Côte Lémanique}
"Françoise" a écrit dans le message de
news:bkpt8s$iu4$Bonsoir,
Encore une fois j'ai besoin de votre aide et je vous en remercie. On m'a
posé une colle et je ne trouve pas la solution. La personne voudrait
calculer les probabilités pour un quinté. On a par exemple 18 chevaux et
on
voudrait afficher toutes les combinaisons possibles. Cela fait 1 028 160
alors qu'il y a seulement 65536 lignes sur Excel. 1ère question : Est-ce
possible ? Si cela ne l'est pas pourrait-on le faire pour un quarté,
cela
ferait seulement 73440 combinaisons possibles. 2ème question : Si on
peut
afficher toutes les combinaisons, comment faire pour ne garder qu'une
probabilité en éliminant les mêmes qui sont dans un ordre différent ?
Salut Françoise,
Oui, les combinaisons sont uniques.
Si tu regardes bien les premières lignes de combinaisons,
avec comme nombres 1 à18, les nombres sont dans l'ordre croissant.
Prends le 1 par exemple, il est en première position de chaque série,
jusqu'à la ligne 2380 et après on ne le retrouve plus......
Bonne chance....Il ne reste plus qu'à éliminer les bourricots parmi les
pur-sang....
--
Amicalement
Jean-François Aubert
{Vaudois de la Côte Lémanique}
"Françoise" a écrit dans le message de
news:bkslva$osn$Bonsoir Jean-François,
Merci beaucoup. Cela a eu beaucoup de succès. Question : est-ce que cela
élimine toutes les mêmes combinaisons qui sont dans un ordre différent
car
vu le nombre de combinaisons il est difficile de vérifier. Encore merci.
"Jean-François Aubert" <à a écrit dans le
message de
news:Salut Françoise,
La procédure donne la liste de toutes les combinaisons
possibles de 5 canassons parmi les 18 partants:
8568 combinaisons
Salut Françoise,
Oui, les combinaisons sont uniques.
Si tu regardes bien les premières lignes de combinaisons,
avec comme nombres 1 à18, les nombres sont dans l'ordre croissant.
Prends le 1 par exemple, il est en première position de chaque série,
jusqu'à la ligne 2380 et après on ne le retrouve plus......
Bonne chance....Il ne reste plus qu'à éliminer les bourricots parmi les
pur-sang....
--
Amicalement
Jean-François Aubert
{Vaudois de la Côte Lémanique}
"Françoise" <f.jeandesbo@wanadoo.fr> a écrit dans le message de
news:bkslva$osn$1@news-reader5.wanadoo.fr...
Bonsoir Jean-François,
Merci beaucoup. Cela a eu beaucoup de succès. Question : est-ce que cela
élimine toutes les mêmes combinaisons qui sont dans un ordre différent
car
vu le nombre de combinaisons il est difficile de vérifier. Encore merci.
"Jean-François Aubert" <àOterjfaubert@bluewin.ch> a écrit dans le
message de
news:3f70a6b7_4@news.bluewin.ch...
Salut Françoise,
La procédure donne la liste de toutes les combinaisons
possibles de 5 canassons parmi les 18 partants:
8568 combinaisons
Salut Françoise,
Oui, les combinaisons sont uniques.
Si tu regardes bien les premières lignes de combinaisons,
avec comme nombres 1 à18, les nombres sont dans l'ordre croissant.
Prends le 1 par exemple, il est en première position de chaque série,
jusqu'à la ligne 2380 et après on ne le retrouve plus......
Bonne chance....Il ne reste plus qu'à éliminer les bourricots parmi les
pur-sang....
--
Amicalement
Jean-François Aubert
{Vaudois de la Côte Lémanique}
"Françoise" a écrit dans le message de
news:bkslva$osn$Bonsoir Jean-François,
Merci beaucoup. Cela a eu beaucoup de succès. Question : est-ce que cela
élimine toutes les mêmes combinaisons qui sont dans un ordre différent
car
vu le nombre de combinaisons il est difficile de vérifier. Encore merci.
"Jean-François Aubert" <à a écrit dans le
message de
news:Salut Françoise,
La procédure donne la liste de toutes les combinaisons
possibles de 5 canassons parmi les 18 partants:
8568 combinaisons
