Tableau de permutations de chiffre sans répétition

Le 04/06/2014 à 03:11

bonjour,

je voudrais savoir comment faire pour réaliser un tableau de permutations de chiffre sans répétition.

le but est simple!

a partir d'un nombre a 4 chiffres je voudrais que le tableau me calcule le nombre de possibilités différentes (toujours en utilisant les 4 chiffres a chaque fois mais dans un ordre différents.

je met le tableau en model.

merci d avance

cdlt

nicolas.

493tableau-de-permutations-de-chiffre-sans-repetition.xlsx (10.63 Ko)
Le 04/06/2014 à 08:05

Bonjour,

Le nombre de possibilité répond à la formule suivante :

= PERMUTATION(4;4)

Etablir la liste des possibilité ne répond à aucune technique particulière :

Il faudrait faire une macro probablement plus chiante à écrire que de faire cette liste manuellement...

A+

Le 04/06/2014 à 11:35

bonjour,

il faudrait juste quond me montre comment faire le début de la macro et je ferai moi même!

cdlt

nicolas

Le 04/06/2014 à 13:52

Sans vouloir t'offenser, c'est un peu comme si tu demandais à apprendre le russe ou le chinois...

Pour apprendre à macroter, voir en haut de cette page la rubrique cours VBA ou cliquer sur ce lien

Voici une macro vraiment faite à l'arrache (car je n'ai pas trop de temps...) qui te liste ça.

Option Explicit

Sub galopin()
'Cette routine génére les nombres de
'1 à k dans un ordre aléatoire
Dim tablo(4), i%, ii%, j%, k%, x%

Application.ScreenUpdating = False
Randomize
k = 4
'ReDim tablo(1 To k)
For ii = 1 To 1000
For i = 1 To k
tablo(i) = i
Next
'mélange
   For i = k To 1 Step -1
     x = Int(((i) * Rnd) + 1)
     j = tablo(x)
     tablo(x) = tablo(i)
     tablo(i) = j
   Next
   For i = 1 To 4
   Cells(ii, i) = tablo(i)
   Next
   Cells(ii, 5) = tablo(1) & tablo(2) & tablo(3) & tablo(4)
Next
'Tri
    With ActiveWorkbook.Worksheets("Feuil1").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("E1"), Order:=xlAscending
    .SetRange Range("A1:E1000")
    .Header = xlNo
    .Apply
End With
'Suppression des doublons
For i = 1000 To 2 Step -1
If Cells(i - 1, 5) = Cells(i, 5) Then Rows(i).Delete
Next
Columns(5).Delete
End Sub

Remarque : En fait la macro fait 1000 tirages puis élimine les doublons

Je l'ai testé 10 fois et à chaque fois j'ai obtenu les 24 possibilités.

Si par hasard ça ne marche pas du premier coup , lancer la macro une autre fois... (ou mettre 2000 au lieu de 1000 !)

Nota : Si tu veux améliorer la chose, au lieu d'afficher puis de concaténer les tirages en colonne 5 tu pourrais les charger dans un Dictionnary ce qui éliminerait les doublons d'office. Et quand ton Dictionnaire serait complet YORAIPUKA afficher le Dico en splitant...

A+

Le 04/06/2014 à 17:31

La même en moins bourrin (Avec Dictionary)

Sub galopin()
Dim tablo(4), i%, ii%, j%, k%, x%, Y As Boolean
k = 4
Application.ScreenUpdating = False
Set Dico = CreateObject("scripting.Dictionary")
Randomize
Do While Not Y
   For i = 1 To k
   tablo(i) = i
   Next
   For i = k To 1 Step -1
   x = Int(((i) * Rnd) + 1)
   j = tablo(x)
   tablo(x) = tablo(i)
   tablo(i) = j
   Next
   Dico(tablo(1) & tablo(2) & tablo(3) & tablo(4)) = ""
Erase tablo
Y = Dico.Count = 24
Debug.Print Dico.Count
Loop
[E1].Resize(Dico.Count, 1) = Application.Transpose(Dico.keys)
For i = 1 To 24
Cells(i, 1) = CInt(Mid(Cells(i, 5), 1, 1))
Cells(i, 2) = CInt(Mid(Cells(i, 5), 2, 1))
Cells(i, 3) = CInt(Mid(Cells(i, 5), 3, 1))
Cells(i, 4) = CInt(Mid(Cells(i, 5), 4, 1))
Next
[E1].Sort Key1:=[E1], Order1:=xlAscending, Header:=xlNo
Columns(5).Delete
End Sub

A+

Le 04/06/2014 à 17:35

houla la!!!

merci de ton aide mais je suis débutant et comme tu dit c est du chinois pour moi tout ca!!!;)

ça me semble bcp trop complexe le machin!

merci comme même pour tes explication galopin01.

salut,

nicolas

Le 05/06/2014 à 13:27

Bonjour,

Pour le fun, une autre version avec procédure récursive

Sub Permutation()
    ' donne toutes les permutations sans doublon de la chaîne de caractères qui se trouve en A1
    texte = Worksheets(1).Range("A1")
    ' résultats en colonne à partir de la cellule A2
    res = "A2"
    If Len(Text) > 9 Then MsgBox "pas plus de neuf caractères": Exit Sub
    For i = Len(texte) To 1 Step -1
        ntext = ntext & Mid(texte, i, 1)
    Next i
    Worksheets(1).Rows("2:" & Worksheets(1).UsedRange.Rows.Count + 1).Delete
    Set sol = Nothing
    perm ntext, sol
    Worksheets(1).Range(res).Resize(sol.Count, 1) = Application.Transpose(sol.keys)
End Sub

Sub perm(texte, ByRef dict, Optional ByRef permutext = Empty)
    If dict Is Nothing Then Set dict = CreateObject("Scripting.Dictionary")
    If permutext = "" Then permutext = texte
    For i = 1 To Len(texte)
        c1 = Left(texte, 1)
        nouveautexte = ""
        Mid(permutext, Len(texte), 1) = Mid(texte, i, 1)
        For j = 2 To Len(texte)
            If j = i Then
                nouveautexte = nouveautexte & c1
            Else
                nouveautexte = nouveautexte & Mid(texte, j, 1)
            End If
        Next j
        If Len(nouveautexte) > 1 Then
            perm nouveautexte, dict, permutext
        Else
            Mid(permutext, 1, 1) = nouveautexte
            If dict.exists(permutext) Then Else dict.Add permutext, 0
        End If
    Next i
End Sub
Le 06/06/2014 à 03:14

merci de vos réponse.. mais je pipe rien!!!

c est possible d'incorporer ça a mon tableau svp!

merci d'avance.

salut

nico.

Le 06/06/2014 à 06:34

Bonjour,

Clic droit sur l'onglet de la feuille + Visualiser le code

Coller la macro suivante :

Sub galopin()
Dim tablo(4), i%, ii%, j%, k%, x%, Y As Boolean
k = 4
Application.ScreenUpdating = False
Set Dico = CreateObject("scripting.Dictionary")
Randomize
Do While Not Y
   For i = 1 To k
   tablo(i) = i
   Next
   For i = k To 1 Step -1
   x = Int(((i) * Rnd) + 1)
   j = tablo(x)
   tablo(x) = tablo(i)
   tablo(i) = j
   Next
   Dico(tablo(1) & tablo(2) & tablo(3) & tablo(4)) = ""
Erase tablo
Y = Dico.Count = 24
'Debug.Print Dico.Count
Loop
[L6].Resize(Dico.Count, 1) = Application.Transpose(Dico.keys)
For i = 6 To 29
Cells(i, 8) = CInt(Mid(Cells(i, 12), 1, 1))
Cells(i, 9) = CInt(Mid(Cells(i, 12), 2, 1))
Cells(i, 10) = CInt(Mid(Cells(i, 12), 3, 1))
Cells(i, 11) = CInt(Mid(Cells(i, 12), 4, 1))
Next
[H6:L29].Sort Key1:=[L6], Order1:=xlAscending, Header:=xlNo
Columns(12).Delete
End Sub

Appuyer sur la touche F5

C'est tout.

A+

Le 06/06/2014 à 12:02

Un grand merci à vous deux pour vos réponses ça marche!

Le 08/06/2017 à 15:49

A la demande d'un autre internaute je donne le code pour 6 éléments :

Sub permut6()
Dim tablo(6), i%, ii%, j%, k%, x%, Dico, Y As Boolean
k = 6
Application.ScreenUpdating = False
Set Dico = CreateObject("scripting.Dictionary")
Randomize
Do While Not Y
For i = 1 To k
tablo(i) = i
Next
For i = k To 1 Step -1
x = Int(((i) * Rnd) + 1)
j = tablo(x)
tablo(x) = tablo(i)
tablo(i) = j
Next
Dico(tablo(1) & tablo(2) & tablo(3) & tablo(4) & tablo(5) & tablo(6)) = ""
Erase tablo
Y = Dico.Count = 720
Debug.Print Dico.Count
Loop
[G1].Resize(Dico.Count, 1) = Application.Transpose(Dico.keys)
For i = 1 To 720
Cells(i, 1) = CInt(Mid(Cells(i, 7), 1, 1))
Cells(i, 2) = CInt(Mid(Cells(i, 7), 2, 1))
Cells(i, 3) = CInt(Mid(Cells(i, 7), 3, 1))
Cells(i, 4) = CInt(Mid(Cells(i, 7), 4, 1))
Cells(i, 5) = CInt(Mid(Cells(i, 7), 5, 1))
Cells(i, 6) = CInt(Mid(Cells(i, 7), 6, 1))
Next
[G1].Sort Key1:=[G1], Order1:=xlAscending, Header:=xlNo
Columns(7).Delete
End Sub

A+

Nota : Avec une présentation un peu différente voir aussi l'excellente proposition de H2So4 qui peut traiter jusqu'à 9 caractères !(alphanumériques) sans aucune modification de la macro...

Sur le modèle de H2So4 une autre macro qui peut traiter également jusqu'à 9 caractères alphanumériques sans modification :

à mettre dans un module standart (Module1)

Dim Dico
Sub AppelCombi()
Dim TexteCombi As String, Tablo
    TexteCombi = Application.InputBox(prompt:="Entrez un string (9 caractères alphanumériques maximum)")
    If Len(TexteCombi) > 9 Then Exit Sub
    Range("A:A").ClearContents
    Set Dico = CreateObject("Scripting.Dictionary")
    Call Combi("", TexteCombi)
    Tablo = Dico.keys
    [A1].Resize(UBound(Tablo) - 1) = Application.Transpose(Tablo)
End Sub

Sub Combi(Prefixe As String, Texte As String)
Dim i As Long
    If Len(Texte) <= 1 Then
        Dico(Prefixe & Texte) = Prefixe & Texte
    Else
        For i = 1 To Len(Texte)
            Call Combi(Prefixe & Mid(Texte, i, 1), Left(Texte, i - 1) & Right(Texte, Len(Texte) - i))
        Next i
    End If
End Sub
Rechercher des sujets similaires à "tableau permutations chiffre repetition"