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 !
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
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é | |
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" <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é
|
|
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
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 !
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
Merci à tous pour votre aide, c'est purement génial !
Hervé
Merci à tous pour votre aide, c'est purement génial !