Algo arrangement (sans répétition)

La reponse de Modeste sur ton fil d'hier ne te conviens pas ?
Moi je la trouve excelente ;-)

platour avait soumis l'idée :

Bonjour, je recherche un algorithme (informatique) permettant de
fournir les arrangements possibles (sans répétition) de p objets
parmi n.

J'ai réussi à mettre au point un algorithme mathématique récursif
qui est très simple et très élégant, mais sa programmation est par
contre (pour moi) compliquée. Ne réussissant pas à mettre au point
le programme, je recherche donc s'il n'existe pas une routine "sur
étagère" en réponse à ce problème.

Voici en détails le problème posé et mon attente pour sa résolution
(pour rappel, les arrangements possibles de 3 objets parmi les 4 de
l'ensemble E = [a, b, c, d] est la collection d'objets [(abc), (abd),
(acd), (bcd)].

Mon attente porte sur un algorithme traitant en donnée d'entrée un
tableau d'indice entier 1 à n, et générant en sortie une matrice
binaire donnant tous les arrangements d'indice possibles, ceci quelque
soit n et p (p>=n). Cette matrice étant alors de taille n!/(n-p)!p!
lignes (nombre d'arrangements) x p
colonnes.

Exemple avec n= 4, p=3, et T=[1, 2, 3, 4] (par analogie avec l'exemple
donné en rappel ci-dessus)
La matrice des arrangements est :
1er ligne = [1 1 1 0] correspondant à l'arrangement (1,2,3)
2ème ligne = [1 1 0 1] correspondant à l'arrangement (1,2,4)
3ème ligne = [1 0 1 1] correspondant à l'arrangement (1,3,4)
4ème ligne = [0 1 1 1] correspondant à l'arrangement (2,3,4)

L'objectif visé par ce programme est le tri (arrangements sans
répétition) de données contenues dans les cellules d'Excel, l'indice
étant le numéro de ligne de la cellule Une résolution avec un
programme écrit en Visual Basic pour Excel serait donc le bien venu.

Merci pour toute aide et assistance à cette résolution.

NB : Si une personne est intéressée par l'équation mathématique
récursive que j'ai mise au point - pour la beauté de la chose - ou si
elle veut s'essayer à la programmer, je n'ai pas d'inconvénient à la
communiquer.

Bonjour platour;
'De Myrna Larson 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
'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
'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()
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
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%(), 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

MP

"platour" <philippe.latour@ecrin.com> a écrit dans le message de news:
1133250565.669770.203470@g43g2000cwa.googlegroups.com...
Bonjour, je recherche un algorithme (informatique) permettant de
fournir les arrangements possibles (sans répétition) de p objets
parmi n.

J'ai réussi à mettre au point un algorithme mathématique récursif
qui est très simple et très élégant, mais sa programmation est par
contre (pour moi) compliquée. Ne réussissant pas à mettre au point
le programme, je recherche donc s'il n'existe pas une routine "sur
étagère" en réponse à ce problème.

Voici en détails le problème posé et mon attente pour sa résolution
(pour rappel, les arrangements possibles de 3 objets parmi les 4 de
l'ensemble E = [a, b, c, d] est la collection d'objets [(abc), (abd),
(acd), (bcd)].

Mon attente porte sur un algorithme traitant en donnée d'entrée un
tableau d'indice entier 1 à n, et générant en sortie une matrice
binaire donnant tous les arrangements d'indice possibles, ceci quelque
soit n et p (p>=n). Cette matrice étant alors de taille n!/(n-p)!p!
lignes (nombre d'arrangements) x p
colonnes.

Exemple avec n= 4, p=3, et T=[1, 2, 3, 4] (par analogie avec l'exemple
donné en rappel ci-dessus)
La matrice des arrangements est :
1er ligne = [1 1 1 0] correspondant à l'arrangement (1,2,3)
2ème ligne = [1 1 0 1] correspondant à l'arrangement (1,2,4)
3ème ligne = [1 0 1 1] correspondant à l'arrangement (1,3,4)
4ème ligne = [0 1 1 1] correspondant à l'arrangement (2,3,4)

L'objectif visé par ce programme est le tri (arrangements sans
répétition) de données contenues dans les cellules d'Excel, l'indice
étant le numéro de ligne de la cellule Une résolution avec un
programme écrit en Visual Basic pour Excel serait donc le bien venu.

Merci pour toute aide et assistance à cette résolution.

NB : Si une personne est intéressée par l'équation mathématique
récursive que j'ai mise au point - pour la beauté de la chose - ou si
elle veut s'essayer à la programmer, je n'ai pas d'inconvénient à la
communiquer.

Mauvaise manipulation, ma requête a été envoyée une deuxième fois
par erreur !
Je prends connaissance seulement ce matin de ces réponses.