Combinaisons

Starwing

23/09/2003 à 19:54

Humm!!

Il me semble que cela s'appelle des permutations Non!

Starwing

-----Message d'origine-----
Bonjour,
je cherche à afficher toutes les combinaisons possible
d'une série de 6

lettres d'une longueur de trois à six lettres.
Le but est de visualiser toutes les combinaisons
possibles (comme pour le

jeu Boggle(R) )
Il me restera ensuite à trouver une solution pour repérer
les mots acceptés

par le correcteur d'orthographe de windows . . . mais ca
ce sera une autre

histoire !

Merci d'avance pour votre aide

Hervé

.

Daniel.j

23/09/2003 à 20:29

Bonsoir
Regarde par là:
http://dj.joss.free.fr/combine.htm

Daniel MVP Excel
FAQ du Forum Microsoft Public Fr Excel
http://dj.joss.free.fr/faq.htm

"RVTISS" a écrit dans le message de news: bkq09s$ur6$
| Bonjour,
| je cherche à afficher toutes les combinaisons possible d'une série de 6
| lettres d'une longueur de trois à six lettres.
| Le but est de visualiser toutes les combinaisons possibles (comme pour le
| jeu Boggle(R) )
| Il me restera ensuite à trouver une solution pour repérer les mots acceptés
| par le correcteur d'orthographe de windows . . . mais ca ce sera une autre
| histoire !
|
| Merci d'avance pour votre aide
|
| Hervé
|
|

Jean-François Aubert

23/09/2003 à 21:31

Salut RVTISS,

Je te propose une macro de Myrna Larson , complétée de 2 macros de mon cru,
cela rassemble touts les "mots" de 3 à 6 lettres sur une même feuille.

'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 (Combinaison ou Permutation)

'2. En A2, écrire la valeur de r <<<--- laisser vide
' la macro de_3_à_6_lettres() s'en occupe

'3. En A3:Ax, écrire la liste des n éléments

'4. Sélectionner A1 et activer la procédure : de_3_à_6_lettres()

'Exemple:
'A1 c
'A2 3
'A3 A
'A4 B
'A5 C
'A7 D
'A8 E
'A9 D

'La procédure donne la liste de toutes les combinaisons
'possibles de 3 à 6 lettres choisies parmi les n éléments.

Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub de_3_à_6_lettres()
Dim i, fe_actu
[a1].Select
fe_actu = ActiveSheet.Name
For i = 3 To 6
[a2] = i
ListPermutations
oter_virgule
Sheets(fe_actu).Select
Next

For i = 2 To 4
Sheets(i).Range("A:A").Copy Sheets(1).Cells(1, i)
Next

Application.DisplayAlerts = False
Sheets(Array(2, 3, 4)).Delete
Application.DisplayAlerts = True
End Sub
Sub oter_virgule()

Columns("A:A").Select
Selection.Replace What:=", ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:úlse
Range("A1").Select
End Sub

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}

"RVTISS" a écrit dans le message de news:bkq09s$ur6$

Bonjour,
je cherche à afficher toutes les combinaisons possible d'une série de 6
lettres d'une longueur de trois à six lettres.
Le but est de visualiser toutes les combinaisons possibles (comme pour le
jeu Boggle(R) )
Il me restera ensuite à trouver une solution pour repérer les mots acceptés
par le correcteur d'orthographe de windows . . . mais ca ce sera une autre
histoire !

Merci d'avance pour votre aide

Hervé

Salut RVTISS,

Je te propose une macro de Myrna Larson , complétée de 2 macros de mon cru,
cela rassemble touts les "mots" de 3 à 6 lettres sur une même feuille.

'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 (Combinaison ou Permutation)

'2. En A2, écrire la valeur de r <<<--- laisser vide
' la macro de_3_à_6_lettres() s'en occupe

'3. En A3:Ax, écrire la liste des n éléments

'4. Sélectionner A1 et activer la procédure : de_3_à_6_lettres()

'Exemple:
'A1 c
'A2 3
'A3 A
'A4 B
'A5 C
'A7 D
'A8 E
'A9 D

'La procédure donne la liste de toutes les combinaisons
'possibles de 3 à 6 lettres choisies parmi les n éléments.

Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub de_3_à_6_lettres()
Dim i, fe_actu
[a1].Select
fe_actu = ActiveSheet.Name
For i = 3 To 6
[a2] = i
ListPermutations
oter_virgule
Sheets(fe_actu).Select
Next

For i = 2 To 4
Sheets(i).Range("A:A").Copy Sheets(1).Cells(1, i)
Next

Application.DisplayAlerts = False
Sheets(Array(2, 3, 4)).Delete
Application.DisplayAlerts = True
End Sub
Sub oter_virgule()

Columns("A:A").Select
Selection.Replace What:=", ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:úlse
Range("A1").Select
End Sub

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}

"RVTISS" <rvtiss@wanado.fr> a écrit dans le message de news:bkq09s$ur6$1@news-reader5.wanadoo.fr...

Bonjour,
je cherche à afficher toutes les combinaisons possible d'une série de 6
lettres d'une longueur de trois à six lettres.
Le but est de visualiser toutes les combinaisons possibles (comme pour le
jeu Boggle(R) )
Il me restera ensuite à trouver une solution pour repérer les mots acceptés
par le correcteur d'orthographe de windows . . . mais ca ce sera une autre
histoire !

Merci d'avance pour votre aide

Hervé

Vous avez filtré cet utilisateur ! Consultez son message

Salut RVTISS,

Je te propose une macro de Myrna Larson , complétée de 2 macros de mon cru,
cela rassemble touts les "mots" de 3 à 6 lettres sur une même feuille.

'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 (Combinaison ou Permutation)

'2. En A2, écrire la valeur de r <<<--- laisser vide
' la macro de_3_à_6_lettres() s'en occupe

'3. En A3:Ax, écrire la liste des n éléments

'4. Sélectionner A1 et activer la procédure : de_3_à_6_lettres()

'Exemple:
'A1 c
'A2 3
'A3 A
'A4 B
'A5 C
'A7 D
'A8 E
'A9 D

'La procédure donne la liste de toutes les combinaisons
'possibles de 3 à 6 lettres choisies parmi les n éléments.

Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub de_3_à_6_lettres()
Dim i, fe_actu
[a1].Select
fe_actu = ActiveSheet.Name
For i = 3 To 6
[a2] = i
ListPermutations
oter_virgule
Sheets(fe_actu).Select
Next

For i = 2 To 4
Sheets(i).Range("A:A").Copy Sheets(1).Cells(1, i)
Next

Application.DisplayAlerts = False
Sheets(Array(2, 3, 4)).Delete
Application.DisplayAlerts = True
End Sub
Sub oter_virgule()

Columns("A:A").Select
Selection.Replace What:=", ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:úlse
Range("A1").Select
End Sub

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}

"RVTISS" a écrit dans le message de news:bkq09s$ur6$

Bonjour,
je cherche à afficher toutes les combinaisons possible d'une série de 6
lettres d'une longueur de trois à six lettres.
Le but est de visualiser toutes les combinaisons possibles (comme pour le
jeu Boggle(R) )
Il me restera ensuite à trouver une solution pour repérer les mots acceptés
par le correcteur d'orthographe de windows . . . mais ca ce sera une autre
histoire !

Merci d'avance pour votre aide

Hervé

RVTISS

24/09/2003 à 23:43

Merci à tous pour votre aide, c'est purement génial !

Hervé

Combinaisons

4 réponses

Veuillez sélectionner un problème