Créer un VB Script capable de trouver toutes les permutations avec répétition d'une chaîne String

**Manudu44** · 11/08/2014, 21h39

Bonjour,

Si je viens de créer cette discussion, c'est pour vous demander votre aide (cela va de soit...

)

Je voudrais créer un script, comme énoncé dans le titre, permettant de trouver toutes les permutations d'une chaîne String.

Seulement, je ne sais pas du tout de quelle manière m'y prendre...

J'ai déjà cherché un peu comment faire, mais chaque fois je tombe sur des sites avec des équations hyper compliquées... Et quand j'affine la recherche, je trouve des scripts faits pour EXCEL (que je ne possède pas, et je voudrais plutôt enregistrer les résultat dans un fichier txt, chose que je sais faire).

Auriez-vous une idée s'il-vous-plaît ?

Bonne continuation,
Manudu44

**ProgElecT** · 11/08/2014, 23h24

Salut, bienvenue sur DVP

toutes les permutations d'une chaîne String

Aurais tu un, voir plusieurs exemples concrets, car cela reste plutôt vague quand au but que tu désires atteindre (chaîne String de départ, chaîne à reconstituer et/ou permutations trouvées ?).

**hackoofr** · 11/08/2014, 23h48

Tu veux faire quelque chose comme ça ?

La chaine introduite par l'utilisateur "abc" le programme va retourner une liste de toutes les combinaisons possibles de cette chaine de caractères:
Résultat dans un fichier :
abc
acb
bac
bca
cab
cba

**Manudu44** · 12/08/2014, 00h25

Bonsoir ProgElecT et hackoofr,

Mon intention est effectivement d'obtenir le résultat proposé par hackoof en partie, car je voudrais ensuite faire aussi des combinaisons...

Je m'explique : je voudras avoir un résultat du genre

a
b
c
...
aa
ab
ac
...
aaa
aab
aac
...

Bref, avoir toutes les possibilités de combinaisons/permutations... Chose pas évidente...

Evidemment, je ne demande qu'à être mis sur la voie, pas que l'on me prémâche tout le boulot

En fait, je suis juste bloqué sur l'algorithme... Je ne sais pas précisément quelles opérations l'ordinateur pourraient éxécuter pour remplir la tâche du script...

Merci pour votre intérêt, votre aide

Bonne nuit

**hackoofr** · 12/08/2014, 01h07

Inspirez-vous de ce code : "Combinaison de chaînes de caractères"
N’oubliez surtout pas le +1

**Manudu44** · 12/08/2014, 16h34

Bonjour,

(Argh ! Vous m'avez prémâché le travail...

Mais ce n'est pas grave...)

Je vais analyser votre script et donc tenter de le modifier dans le but d'obtenir le résultat voulu...

Merci !

Bien évidemment, une fois le script finalisé, je posterais ma version ici, et passerait la discussion au statut de "résolue", si je ne rencontre pas de problème...

Bonne continuation,
Manudu44

**Manudu44** · 13/08/2014, 12h32

Envoyé par hackoofr

Inspirez-vous de ce code : "Combinaison de chaînes de caractères"
N’oubliez surtout pas le +1

Le problème de ce code, c'est que l'on ne peut pas retrouver plusieurs fois la même lettre...

J'ai continué mes recherches sur internet... Voici ce que je veux faire :

COMBINAISON AVEC REPETITION (et, si possible, pouvoir choisir la longueur des combinaisons...)
http://fr.wikipedia.org/wiki/Combina...9p%C3%A9tition

**Cachlab** · 14/08/2014, 13h24

Salut !

Ah ça fait plaisir de se replonger dans les calculs de probabilités !

Si j'ai bien compris ton souhait, il va falloir préciser le nombre de répétitions et le nombre d'objets.
Même si les résultats sont moindre entre une combinaison et un arrangement, tu vas vite arriver à un nombre de résultats faramineux.

En effet, dans ton exemple, tu disposes de 3 objets (A, B et C).
L'idée étant d'effectuer un certain nombre de tirages en remettant à chaque fois l'objet disponible (contrairement au loto où l'on ne peut pas tirer 2 fois le même objet) et sans se soucier de l'ordre du tirage (comme au loto où l'ordre n'a pas d'importance).

n = nombre d'objets
k = nombre de tirages
La formule est (k+n-1)! / (k! x (n-1)!)
Ca se lit : factoriel de (k + n - 1) divisé par (factoriel de k multiplié par factoriel de n-1)

La 1ère fois tu effectues un seul tirage :
Résultat : A, B ou C = 3 possibilités.
Formule : (1+3-1)! / (1! x 2!) = 3

La 2ème fois tu effectues 2 tirages :
Résultats : 2A, 2B, 2C, 1A+1B, 1A+1C, 1B+1C = 6 possibilités.
Formule : (2+3-1)! / (2! x 2!) = 6

La 3ème fois tu effectues 3 tirages :
Résultats : 3A, 3B, 3C, 2A1B, 2A1C, 2B1A, 2B1C, 2C1A, 2C1B, 1A1B1C = 10 possibilités.
Formule : (3+3-1)! / (3! x 2!) = 10
...

Le problème est intéressant ...
Malheureusement, j'ai peur qu'il faille passer d'abord par la liste des arrangements possibles, avant d'en extraire les combinaisons voulues.
Et là, on commence à obtenir un nombre de possibilités énorme (n^k) ...

Dans un arrangement, l'ordre des objets est pris en compte, donc ABC est différent de BCA par exemple.
Dans une combinaison, ce n'est pas le cas, donc ABC = BCA = CAB = CBA ...

Si l'on reprend ton exemple en calculant les arrangements possibles :
n = nombre d'objets
k = nombre de tirages
La formule est n^k (n puissance k)

La 1ère fois tu effectues un seul tirage :
Résultat : A, B ou C = 3 possibilités.
Formule : 3^1 = 3

La 2ème fois tu effectues 2 tirages :
Résultats : AA, AB, AC, BA, BB, BC, CA, CB, CC = 9 possibilités.
Formule : 3^2 = 9

La 3ème fois tu effectues 3 tirages :
Résultats : AAA, AAB, AAC, ABA, ABB, ABC, ACA, ACB, ACC, BAA, BAB, BAC, BBA, BBB, BBC, BCA, BCB, BCC, CAA, CAB, CAC, CBA, CBB, CBC, CCA, CCB, CCC = 27 possibilités.
Formule : 3^3 = 27
...

Une fois que tu as ces 27 arrangements (pour le dernier exemple), il faut pouvoir les tester entre eux et ne conserver que les 10 combinaisons qui t'intéressent :
1. AAA
2. BBB
3. CCC
4. AAB = ABA = BAA
5. AAC = ACA = CAA
6. ABB = BAB = BBA
7. BBC = BCB = CBB
8. CCA = CAC = ACC
9. CCB = CBC = BCC
10. ABC = BAC = BCA = CAB = CBA = ACB

Il me semble donc que la proposition d'Hackoofr peut être une bonne base de départ pour dénombrer les arrangements.
Cependant, il faudra ensuite ajouter un algorythme de comparaison des résultats pour extraire les combinaisons.

Je pense que la meilleure approche serait de compter le nombre d'objets par tirage et de tout coller dans un tableau.
Par exemple transformer ABB en 1A2B0C, du coup BAB donne aussi 1A2B0C ... et aprés tu élimines les doublons.

Je n'ai pas le temps actuellement de me pencher sur un tel sujet, mais si quelqu'un a envie de s'amuser avec cela, je suis curieux de connaitre le résultat !

Bon courage en tous cas !

**ProgElecT** · 14/08/2014, 17h19

Salut

Une adaptation d'un code VB6, très peu commenté car je n'ai pas trop de temps pour le moment, mais je suis la discussion et pourrai ré-intervenir pour apporter des précisions plus tard.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
Option Explicit
'Création d'un type utilisateur
Class TblData
	Dim Contenu,Idx
End Class
'//////////////////////////////////// les Sub et Fonctions \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
Function ElimineDoublon(TblElements)
    Dim Cpt1, Cpt2, Doublon, ElemNbr
 
    ElemNbr = UBound(TblElements)
    For Cpt1 = 0 To ElemNbr
        Doublon = False
        For Cpt2 = Cpt1 + 1 To ElemNbr
            If TblElements(Cpt1) = TblElements(Cpt2) Then Doublon = True: Exit For
        Next
        If Doublon = False Then
            ElimineDoublon = ElimineDoublon & TblElements(Cpt1)
            If Cpt1 <> ElemNbr Then ElimineDoublon = ElimineDoublon & ","
        End If
    Next
End Function
'---------------------------------------------------------------
Function TrierTbl(TblDonn)
	Dim Cpt1, Cpt2, CountTbl
	Dim MotIdxH, MotIdxB
	Dim MeTbl
 
	'utile si le tableau soumis n'est pas valide (aucun indice) UBound(TblDonn) provocant une erreur
	On Error Resume Next
	If UBound(TblDonn) = 0 Then TrierTbl = TblDonn: Exit Function
	If Err Then TblDonn = vbEmpty : Exit Function ' cas du tableau soumis non valide
 
	MeTbl = TblDonn
	CountTbl = UBound(MeTbl)'nombre d'indices du tableau
	'double boucle pour le tri effectif
	For Cpt1 = 0 To CountTbl
		For Cpt2 = CountTbl To 1 Step -1
			MotIdxB = MeTbl(Cpt2 - 1)
			MotIdxH = MeTbl(Cpt2)
			If UCase(MotIdxB) > UCase(MotIdxH) Then
				MeTbl(Cpt2) = MotIdxB
				MeTbl(Cpt2 - 1) = MotIdxH
			End If
		Next
	Next
 
	TrierTbl = MeTbl 'retour du tableau trié
End Function
'---------------------------------------------------------------
Sub PourAfficher(LeTexte)
	Dim Objobj, objFile
	Set Objobj = CreateObject("Scripting.FileSystemObject")
	Set objFile = Objobj.CreateTextFile("C:\ResulTemp.txt", True)
	objFile.WriteLine LeTexte
	objFile.Close: Set objFile = Nothing
	Set Objobj = WScript.CreateObject("WScript.Shell")
	Objobj.Run "notepad C:\ResulTemp.txt"
	Set Objobj = Nothing
End Sub'//////////////////////////////////// Fin des Sub et Fonctions \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 
'********************************************** partie principale ******************************************
Dim LeTableau(), TableauFinal()' As String
Dim TbleauChifre()' As String
Dim Provis' As String
Dim T, U, NbrElem, NbrMaxiDiff' As Long
Dim Reponse, TxtRech, ChaineDeChiffrage ' As String
'les 5 lignes suivantes a remer/deremer pour faire des essais, la variable Reponse doit contenir les éléments à combiner
Reponse = "Cerise,Pomme,Poire,Citron,Banane" ' 5 éléments
'Reponse = "Cerise,Pomme,Poire,Citron,Banane,Abricot" ' 6 éléments
'Reponse = "Cerise,Pomme,Abricot,Citron,Banane,Abricot,Poires" ' 7 éléments avec 1 doublon
'Reponse = "Cerise,Pomme,Poire,Citron,Banane,Abricot,Raisin" ' 7 éléments
'Reponse = Trim(InputBox("Entrez vos éléments séparés par des virgules", "Entrées éléments (Mini 2)"))
 
If Reponse = "" Then WScript.Quit
 
Reponse = ElimineDoublon(Split(Reponse, ","))
Provis = TrierTbl(Split(Reponse, ",")) ' Tri
 
NbrElem = UBound(Provis) + 1
If NbrElem <= 1 Then WScript.Quit
 
'****************************** Ma méthode pour trouver toutes les combinaisons possibles, sans doublon ************************************
NbrMaxiDiff = (2 ^ NbrElem) - 1
For T = 1 To NbrMaxiDiff: ChaineDeChiffrage = ChaineDeChiffrage & CStr(T) & ",": Next
ChaineDeChiffrage = "," & ChaineDeChiffrage
 
ReDim LeTableau(NbrElem - 1)
For T = NbrElem To 1 Step -1
	Set LeTableau(T - 1) = new TblData
	With LeTableau(T - 1)
		.Contenu = Provis(T - 1): .Idx = 2 ^ (T - 1)
		TxtRech = "," & CStr(.Idx)
	End With
	ChaineDeChiffrage = Replace(ChaineDeChiffrage, TxtRech, "", 1, 1, 0)
Next
'Élimination des 2 virgules début et fin
ChaineDeChiffrage = Left(ChaineDeChiffrage, Len(ChaineDeChiffrage) - 1)
ChaineDeChiffrage = Right(ChaineDeChiffrage, Len(ChaineDeChiffrage) - 1)
Provis = Split(ChaineDeChiffrage, ",")
 
ReDim TbleauChifre(UBound(Provis))
For T = 0 To UBound(Provis): TbleauChifre(T) = CLng(Provis(T)): Next
 
ReDim TableauFinal(UBound(TbleauChifre))
TxtRech = "Vos éléments:" & vbNewLine & Reponse & vbNewLine
TxtRech = TxtRech & "Nbr. de combinaisons différentes: " & NbrMaxiDiff - NbrElem & " pour " & NbrElem & " éléments." & vbNewLine & vbNewLine
For T = 0 To UBound(TbleauChifre)
	Set TableauFinal(T) = new TblData
	TableauFinal(T).Idx = TbleauChifre(T)
	For U = UBound(LeTableau) To 0 Step -1
		If TbleauChifre(T) >= LeTableau(U).Idx Then
			TableauFinal(T).Contenu = Trim(TableauFinal(T).Contenu) & " " & LeTableau(U).Contenu
			TbleauChifre(T) = TbleauChifre(T) - LeTableau(U).Idx
		End If
	Next
	TxtRech = TxtRech & TableauFinal(T).Contenu
	If T <> UBound(TbleauChifre) Then TxtRech = TxtRech & vbNewLine
Next
'*************************** Fin de ma méthode pour trouver toutes les combinaisons possibles, sans doublon ********************************
 
If NbrElem <= 5 Then 'suffisamment petit pour afficher dans un Msgbox
	MsgBox TxtRech
	Else 'trop grand pour être affiché dans un Msgbox, passer par un fichier temporaire
	PourAfficher TxtRech
End If
'********************************************* Fin partie principale ***************************************

Envoyé par Cachlab

Dans un arrangement, l'ordre des objets est pris en compte, donc ABC est différent de BCA par exemple.
Dans une combinaison, ce n'est pas le cas, donc ABC = BCA = CAB = CBA ...

Motif de l’édition, complément du code.

**Manudu44** · 14/08/2014, 21h25

Bonjour.

J'ai (re-)continué mes recherches sur internet... Voici ce que je veux finalement faire (je m'embrouille avec les permutations et les combinaisons avec ou sans répétition...

):

PERMUTATION AVEC REPETITION (et, si possible, pouvoir choisir la longueur des combinaisons...)
http://fr.wikipedia.org/wiki/Permuta...9p%C3%A9tition

Cachlab, merci de tes explications

(un peu trop de maths à mon goût, mais merci quand même de ton aide, j'ai essayé de lire tout ton message et, plus compliqué, de le comprendre...)

Merci aussi ProgElecT, je vais analyser ton code...

Bonne continuation,
Manudu44

**Manudu44** · 15/08/2014, 12h31

Bonjour.

Je pense que je vais essayer de faire un algorithme qui :

demande la longueur voulue ainsi que les éléments, et duplique le premier élément autant de fois que la longueur
se focalise ensuite sur le dernier caractère, et le change selon l'ordre de la liste des éléments (en sauvegardant la valeur à chaque changement)
si un caractère actuel arrive au dernier élément, alors changer d'un seul élément le précédent, et recommencer avec le caractère actuel
si un caractère précédent arrive au dernier élément, alors changer d'un seul élément le précédent du précédent, et recommencer avec le caractère actuel
si le premier caractère correspond au dernier élément, alors stopper les opérations

Exemple :

Je rentre la longueur, et 3 éléments (A,B,C)

AAA -> Regarde le dernier caractère
AAB -> Change le caractère actuel
AAC -> Change le caractère actuel (Attention, dernier élément)
ABC -> Change le caractère précédent (sans sauvegarder cette étape)
ABA -> Remet le caractère actuel à zéro
ABB -> Change le caractère actuel
ABC -> Change le caractère actuel (Attention, dernier élément)
ACC -> Change le caractère précédent (sans sauvegarder cette étape)
ACA -> Remet le caractère actuel à zéro
ACB -> Change le caractère actuel
ACC -> Change le caractère actuel (Attention, dernier élément)
BCC -> Change le caractère précédent au précédent, car le caractère précédent est au dernier élément (sans sauvegarder cette étape)
BAA -> Remet les caractères suivant le précédent à zéro
BAB -> Change le caractère actuel
BAC -> Change le caractère actuel (Attention, dernier élément)
BBC -> Change le caractère précédent (sans sauvegarder cette étape)
BBA -> Remet le caractère actuel à zéro
BBB -> Change le caractère actuel
BBC -> Change le caractère actuel (Attention, dernier élément)
BCC -> Change le caractère précédent
BCA -> Remet le caractère actuel à zéro
BCB -> Change le caractère actuel
BCC -> Change le caractère actuel (Attention, dernier élément)
CCC -> Change le caractère précédent au précédent, car le caractère précédent est au dernier élément (sans sauvegarder cette étape)
CAA -> Remet les caractères suivant le précédent à zéro
CAB -> Change le caractère actuel
CAC -> Change le caractère actuel (Attention, dernier élément)
CBC -> Change le caractère précédent (sans sauvegarder)
CBA -> Remet le caractère actuel à zéro
CBB -> Change le caractère actuel
CBC -> Change le caractère actuel (Attention, dernier élément)
CCC -> Change le caractère précédent
CCA -> Remet le caractère actuel à zéro
CCB -> Change le caractère actuel
CCC -> Change le caractère actuel (Attention, dernier élément)
CCC -> TOUT LES CARACTÈRES SONT AU DERNIER ÉLÉMENT, ARRÊTER SANS SAUVEGARDER CETTE ETAPE

Bonne journée,
Manudu44

**Manudu44** · 15/08/2014, 13h37

Salut à tous !

Voici un petit début de code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Const ForWriting = 2
Set fso = CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")
 
 
txt_File_Location = fso.GetParentFolderName(wscript.ScriptFullName) + "\Permutations avec répétition.txt" 'Emplacement du fichier .txt de sauvegarde des résultat
If fso.FileExists(txt_File_Location) Then fso.DeleteFile txt_File_Location 'S'il existe déjà, le supprimer pour vider la liste de résultat
Set txt_File = fso.OpenTextFile(txt_file_location, ForWriting, true)
 
Longueur = InputBox("Entrez la longueur du résultat" + vbNewLine + vbNewLine + "Pour des raisons de code et de temps de calcul, vous êtes limité à 10 caratères." + vbNewLine + vbNewLine + vbNewLine + "Les caractères en trop seront tout simplement ignorés des opérations", "Entrée de la longueur du résultat", "3")
If Longueur = "" OR Longueur = "0" Then Erreur = WshShell.Popup("Veuillez entrer une valeur au dessus de 0", 5, "ERROR", 0 + 64) : WScript.Quit 'Si la variable n'a pas de valeur, quitter
Elements = Trim(InputBox("Entrez vos éléments, séparés par des virgules" + vbNewLine + vbNewLine + "Pour des raisonsde temps de calcul, il est conseillé de limiter à 10 éléments." + vbNewLine + vbNewLine + vbNewLine + "Les éléments en trop seront tout simplement ignorés des opérations", "Entrée des éléments", "A, B, C"))
If Elements = "" Then Erreur = WshShell.Popup("Veuillez entrer une valeur", 5, "ERROR", 0 + 64) : WScript.Quit 'Si la variable n'a pas de valeur, quitter
 
Elements = Replace(Elements, " ", "")
Cut = Split(Elements, ",") 'Pour séparer les éléments
 
 
If Len(Elements) = 1 Then txt_File.WriteLine Cut(0) : WScript.Quit 'S'il n'y a qu'un élément, l'écrire et quitter
Chaine = String(Longueur, Cut(0))
 
Do While Instr(1, Left(Chaine, 1), Cut(UBound(Cut))) = 0 'Faire tant que le premier caractère de Chaine ne soit pas égal au dernier élément
 
   txt_File.WriteLine Chaine 'Ecrire le résultat
   If NOT Right(Chaine, 1) = Cut(UBound(Cut)) Then
      If Number_Right_1 = Cut(UBound(Cut)) Then Number_Right_1 = 0
      Number_Right_1 = Number_Right_1 + 1
      Chaine = Replace(Chaine, Right(Chaine, 1), Cut(Number_Right_1))
   Else
      If Number_Right_2 = Cut(UBound(Cut)) Then Number_Right_2 = 0
      Number_Right_2 = Number_Right_2 + 1
      Chaine = Replace(Chaine, Right(Right(Chaine, 1), 1), Cut(Number_Right_2))
   End If
 
Loop
 
 
 
Fin = WshShell.Popup("Fin des opérations", 5, "Traitement", 0 + 64)

Le traitement en lui même risque de poser des problèmes...

**Manudu44** · 16/08/2014, 10h02

Aïe... Je me mélange avec les conditions, les incrémentations...

Ce qui me pose problème, c'est le repérage du caractère à modifier... (à la fin du code...)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Const ForWriting = 2
Set fso = CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")
 
 
txt_File_Location = fso.GetParentFolderName(wscript.ScriptFullName) + "\Permutations avec répétition.txt" 'Emplacement du fichier .txt de sauvegarde des résultat
If fso.FileExists(txt_File_Location) Then fso.DeleteFile txt_File_Location 'S'il existe déjà, le supprimer pour vider la liste de résultat
Set txt_File = fso.OpenTextFile(txt_file_location, ForWriting, true)
 
Longueur = InputBox("Entrez la longueur du résultat" + vbNewLine + vbNewLine + "Pour des raisons de code et de temps de calcul, vous êtes limité à 10 caratères." + vbNewLine + vbNewLine + vbNewLine + "Les caractères en trop seront tout simplement ignorés des opérations", "Entrée de la longueur du résultat", "3")
If Longueur = "" OR Longueur = "0" Then Erreur = WshShell.Popup("Veuillez entrer une valeur au dessus de 0", 5, "ERROR", 0 + 64) : WScript.Quit 'Si la variable n'a pas de valeur, quitter
Elements = Trim(InputBox("Entrez vos éléments, séparés par des virgules" + vbNewLine + vbNewLine + "Pour des raisons de code et de temps de calcul, vous êtes limité à 10 éléments." + vbNewLine + vbNewLine + vbNewLine + "Les éléments en trop seront tout simplement ignorés des opérations", "Entrée des éléments", "A, B, C"))
If Elements = "" Then Erreur = WshShell.Popup("Veuillez entrer une liste d'éléments" + vbNewLine + "comportant entre 1 et 10 caractères", 5, "ERROR", 0 + 64) : WScript.Quit 'Si la variable n'a pas de valeur, quitter
 
Elements = Replace(Elements, " ", "")
Cut = Split(Elements, ",")
 
If Len(Elements) = 1 Then txt_File.WriteLine Cut(0) : WScript.Quit 'S'il n'y a qu'un élément, l'écrire et quitter
Chaine = Cut(0) + Cut (0) + Cut (0) + Cut (0) + Cut (0) + Cut (0) + Cut (0) + Cut (0) + Cut (0) + Cut (0)
Chaine = Left(Chaine, Longueur)
 
For i = 1 to (UBound(Cut) + 1) ^ Longueur
 
   txt_File.WriteLine Chaine 'Ecrire le résultat
 
   Number_Left_1 = Number_Left_1 + 1
   If NOT Left(Chaine, 1) = Cut(UBound(Cut)) Then
      temp1 = (InStr(chaine, Cut(Number_Left_1 - 1)))
      remplace1 = Cut(Number_Left_1)
      chaine = Left(chaine, temp1 - 1) + remplace1 + Right(chaine, Len(chaine) - temp1)
   Else
      Number_Left_1 = Number_Left_1 - UBound(Cut)
      Number_Left_2 = Number_Left_2 + 1
      temp2 = (InStr(chaine, Cut(Number_Left_2)))
      remplace2 = Cut(Number_Left_2)
      chaine = Left(chaine, temp2) + remplace2 + Right(chaine, Len(chaine) - temp2 - 1)
   End If
 
Next
 
 
 
Fin = WshShell.Popup("Fin des opérations", 5, "Traitement", 0 + 64)

Pouvez-vous m'aider s'il-vous-plaît ?

**Manudu44** · 16/08/2014, 12h49

J'AI RÉUSSI ! ! !

Mon code fonctionne, je vais donc vous le mettre ci-dessous :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
Const ForWriting = 2
Set fso = CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")
 
 
txt_File_Location = fso.GetParentFolderName(wscript.ScriptFullName) + "\Permutations avec répétition.txt" 'Emplacement du fichier .txt de sauvegarde des résultat
If fso.FileExists(txt_File_Location) Then fso.DeleteFile txt_File_Location 'S'il existe déjà, le supprimer pour vider la liste de résultat
Set txt_File = fso.OpenTextFile(txt_file_location, ForWriting, true)
 
Longueur = InputBox("Entrez la longueur du résultat" + vbNewLine + vbNewLine + "Pour des raisons de code et de temps de calcul, vous êtes limité à 10 caratères." + vbNewLine + vbNewLine + vbNewLine + "Les caractères en trop seront tout simplement ignorés des opérations", "Entrée de la longueur du résultat", "3")
If Longueur = "" OR Longueur = "0" Then Erreur = WshShell.Popup("Veuillez entrer une valeur au dessus de 0", 5, "ERROR", 0 + 64) : WScript.Quit 'Si la variable n'a pas de valeur, quitter
Elements = Trim(InputBox("Entrez vos éléments, séparés par des virgules" + vbNewLine + vbNewLine + "Pour des raisons de code et de temps de calcul, vous êtes limité à 10 éléments." + vbNewLine + vbNewLine + vbNewLine + "Les éléments en trop seront tout simplement ignorés des opérations", "Entrée des éléments", "A, B, C"))
If Elements = "" Then Erreur = WshShell.Popup("Veuillez entrer une liste d'éléments" + vbNewLine + "comportant entre 1 et 10 caractères", 5, "ERROR", 0 + 64) : WScript.Quit 'Si la variable n'a pas de valeur, quitter
 
Elements = Replace(Elements, " ", "")
Cut = Split(Elements, ",")
 
If Len(Elements) = 1 Then txt_File.WriteLine Cut(0) : WScript.Quit 'S'il n'y a qu'un élément, l'écrire et quitter
Chaine = Cut(0) + Cut (0) + Cut (0) + Cut (0) + Cut (0) + Cut (0) + Cut (0) + Cut (0) + Cut (0) + Cut (0)
Chaine = Left(Chaine, Longueur)
 
For i = 1 to (UBound(Cut) + 1) ^ Longueur
 
   txt_File.WriteLine Chaine 'Ecrire le résultat
 
   If Left(Chaine, 1) = Cut(UBound(Cut)) Then
      Number_Left_1 = 0
      If Mid(Chaine, 2, 1) = Cut(UBound(Cut)) Then
         Number_Left_2 = 0
         If Mid(Chaine, 3, 1) = Cut(UBound(Cut)) Then
            Number_Left_3 = 0
            If Mid(Chaine, 4, 1) = Cut(UBound(Cut)) Then
               Number_Left_4 = 0
               If Mid(Chaine, 5, 1) = Cut(UBound(Cut)) Then
                  Number_Left_5 = 0
                  If Mid(Chaine, 6, 1) = Cut(UBound(Cut)) Then
                     Number_Left_6 = 0
                     If Mid(Chaine, 7, 1) = Cut(UBound(Cut)) Then
                        Number_Left_7 = 0
                        If Mid(Chaine, 8, 1) = Cut(UBound(Cut)) Then
                           Number_Left_8 = 0
                           If Mid(Chaine, 9, 1) = Cut(UBound(Cut)) Then
                              Number_Left_9 = 0
                              If Mid(Chaine, 10, 1) = Cut(UBound(Cut)) Then
                                 Number_Left_10 = 0
                              Else
                                 Number_Left_10 = Number_Left_10 + 1
                                 Chaine = Cut(Number_Left_1) + Cut (Number_Left_2) + Cut (Number_Left_3) + Cut (Number_Left_4) + Cut (Number_Left_5) + Cut (Number_Left_6) + Cut (Number_Left_7) + Cut (Number_Left_8) + Cut (Number_Left_9) + Cut (Number_Left_10)
                                 Chaine = Left(Chaine, Longueur)
                              End If
                           Else
                              Number_Left_9 = Number_Left_9 + 1
                              Chaine = Cut(Number_Left_1) + Cut (Number_Left_2) + Cut (Number_Left_3) + Cut (Number_Left_4) + Cut (Number_Left_5) + Cut (Number_Left_6) + Cut (Number_Left_7) + Cut (Number_Left_8) + Cut (Number_Left_9) + Cut (Number_Left_10)
                              Chaine = Left(Chaine, Longueur)
                           End If
                        Else
                           Number_Left_8 = Number_Left_8 + 1
                           Chaine = Cut(Number_Left_1) + Cut (Number_Left_2) + Cut (Number_Left_3) + Cut (Number_Left_4) + Cut (Number_Left_5) + Cut (Number_Left_6) + Cut (Number_Left_7) + Cut (Number_Left_8) + Cut (Number_Left_9) + Cut (Number_Left_10)
                           Chaine = Left(Chaine, Longueur)
                        End If
                     Else
                        Number_Left_7 = Number_Left_7 + 1
                        Chaine = Cut(Number_Left_1) + Cut (Number_Left_2) + Cut (Number_Left_3) + Cut (Number_Left_4) + Cut (Number_Left_5) + Cut (Number_Left_6) + Cut (Number_Left_7) + Cut (Number_Left_8) + Cut (Number_Left_9) + Cut (Number_Left_10)
                        Chaine = Left(Chaine, Longueur)
                     End If
                  Else
                     Number_Left_6 = Number_Left_6 + 1
                     Chaine = Cut(Number_Left_1) + Cut (Number_Left_2) + Cut (Number_Left_3) + Cut (Number_Left_4) + Cut (Number_Left_5) + Cut (Number_Left_6) + Cut (Number_Left_7) + Cut (Number_Left_8) + Cut (Number_Left_9) + Cut (Number_Left_10)
                     Chaine = Left(Chaine, Longueur)
                  End If
               Else
                  Number_Left_5 = Number_Left_5 + 1
                  Chaine = Cut(Number_Left_1) + Cut (Number_Left_2) + Cut (Number_Left_3) + Cut (Number_Left_4) + Cut (Number_Left_5) + Cut (Number_Left_6) + Cut (Number_Left_7) + Cut (Number_Left_8) + Cut (Number_Left_9) + Cut (Number_Left_10)
                  Chaine = Left(Chaine, Longueur)
               End If
            Else
               Number_Left_4 = Number_Left_4 + 1
               Chaine = Cut(Number_Left_1) + Cut (Number_Left_2) + Cut (Number_Left_3) + Cut (Number_Left_4) + Cut (Number_Left_5) + Cut (Number_Left_6) + Cut (Number_Left_7) + Cut (Number_Left_8) + Cut (Number_Left_9) + Cut (Number_Left_10)
               Chaine = Left(Chaine, Longueur)
            End If
         Else
            Number_Left_3 = Number_Left_3 + 1
            Chaine = Cut(Number_Left_1) + Cut (Number_Left_2) + Cut (Number_Left_3) + Cut (Number_Left_4) + Cut (Number_Left_5) + Cut (Number_Left_6) + Cut (Number_Left_7) + Cut (Number_Left_8) + Cut (Number_Left_9) + Cut (Number_Left_10)
            Chaine = Left(Chaine, Longueur)
         End If
      Else
         Number_Left_2 = Number_Left_2 + 1
         Chaine = Cut(Number_Left_1) + Cut (Number_Left_2) + Cut (Number_Left_3) + Cut (Number_Left_4) + Cut (Number_Left_5) + Cut (Number_Left_6) + Cut (Number_Left_7) + Cut (Number_Left_8) + Cut (Number_Left_9) + Cut (Number_Left_10)
         Chaine = Left(Chaine, Longueur)
      End If
   Else
      Number_Left_1 = Number_Left_1 + 1
      Chaine = Cut(Number_Left_1) + Cut (Number_Left_2) + Cut (Number_Left_3) + Cut (Number_Left_4) + Cut (Number_Left_5) + Cut (Number_Left_6) + Cut (Number_Left_7) + Cut (Number_Left_8) + Cut (Number_Left_9) + Cut (Number_Left_10)
      Chaine = Left(Chaine, Longueur)
   End If
 
Next
 
 
 
Fin = WshShell.Popup("Fin des opérations", 5, "Traitement", 0 + 64)

Je tiens à remercier toutes les personnes qui m'ont aidées pour obtenir ce résultat. MERCI !

Bonne journée à tous ! ! !

Manudu44

**Manudu44** · 16/08/2014, 20h05

Voilà, voilà... Petite MAJ...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
Const ForWriting = 2
Set fso = CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")
 
 
txt_File_Location = fso.GetParentFolderName(wscript.ScriptFullName) + "\Permutations avec répétition.txt" 'Emplacement du fichier .txt de sauvegarde des résultat
If fso.FileExists(txt_File_Location) Then fso.DeleteFile txt_File_Location 'S'il existe déjà, le supprimer pour vider la liste de résultat
Set txt_File = fso.OpenTextFile(txt_file_location, ForWriting, true)
 
Longueur = InputBox("Entrez la longueur du résultat" + vbNewLine + vbNewLine + "Pour des raisons de code et de temps de calcul, vous êtes limité à 20 caratères" + vbNewLine + vbNewLine + vbNewLine + "Les caractères en trop seront tout simplement ignorés des opérations", "Entrée de la longueur du résultat", "3")
'Longueur = "3" 'Si cette ligne est activée, neutralisez la précédente
If Longueur = "" OR Longueur = "0" Then Erreur = WshShell.Popup("Veuillez entrer une valeur au dessus de 0", 5, "ERROR", 0 + 64) : WScript.Quit 'Si la variable n'a pas de valeur, quitter
Elements = Trim(InputBox("Entrez vos éléments, séparés par des virgules" + vbNewLine + vbNewLine + "Pour des raisons de temps de calcul, il est conseillé de se limiter à 10 éléments" + vbNewLine + vbNewLine + vbNewLine + "Un nombre trop important d'éléments augmentera considérablement le temps d'attente", "Entrée des éléments", "A, B, C"))
'Elements = "A, B, C" 'Si cette ligne est activée, neutralisez la précédente
If Elements = "" Then Erreur = WshShell.Popup("Veuillez entrer une liste d'éléments" + vbNewLine + "comportant entre 1 et 10 caractères", 5, "ERROR", 0 + 64) : WScript.Quit 'Si la variable n'a pas de valeur, quitter
 
Elements = Replace(Elements, " ", "")
Cut = Split(Elements, ",")
 
If Len(Elements) = 1 Then txt_File.WriteLine Cut(0) : WScript.Quit 'S'il n'y a qu'un élément, l'écrire et quitter
 
For i = 1 to (UBound(Cut) + 1) ^ Longueur
 
   Chaine = Cut(Number_Left_1) + Cut(Number_Left_2) + Cut(Number_Left_3) + Cut(Number_Left_4) + Cut(Number_Left_5) + Cut(Number_Left_6) + Cut(Number_Left_7) + Cut(Number_Left_8) + Cut (Number_Left_9) + Cut (Number_Left_10) + Cut(Number_Left_11) + Cut(Number_Left_12) + Cut(Number_Left_13) + Cut(Number_Left_14) + Cut(Number_Left_15) + Cut(Number_Left_16) + Cut(Number_Left_17) + Cut(Number_Left_18) + Cut(Number_Left_19) + Cut(Number_Left_20)
   Chaine = Left(Chaine, Longueur)
   txt_File.WriteLine Chaine 'Ecrire le résultat
 
   If Left(Chaine, 1) = Cut(UBound(Cut)) Then
      Number_Left_1 = 0
      If Mid(Chaine, 2, 1) = Cut(UBound(Cut)) Then
         Number_Left_2 = 0
         If Mid(Chaine, 3, 1) = Cut(UBound(Cut)) Then
            Number_Left_3 = 0
            If Mid(Chaine, 4, 1) = Cut(UBound(Cut)) Then
               Number_Left_4 = 0
               If Mid(Chaine, 5, 1) = Cut(UBound(Cut)) Then
                  Number_Left_5 = 0
                  If Mid(Chaine, 6, 1) = Cut(UBound(Cut)) Then
                     Number_Left_6 = 0
                     If Mid(Chaine, 7, 1) = Cut(UBound(Cut)) Then
                        Number_Left_7 = 0
                        If Mid(Chaine, 8, 1) = Cut(UBound(Cut)) Then
                           Number_Left_8 = 0
                           If Mid(Chaine, 9, 1) = Cut(UBound(Cut)) Then
                              Number_Left_9 = 0
                              If Mid(Chaine, 10, 1) = Cut(UBound(Cut)) Then
                                 Number_Left_10 = 0
                                 If Mid(Chaine, 11, 1) = Cut(UBound(Cut)) Then
                                    Number_Left_11 = 0
                                    If Mid(Chaine, 12, 1) = Cut(UBound(Cut)) Then
                                       Number_Left_12 = 0
                                       If Mid(Chaine, 13, 1) = Cut(UBound(Cut)) Then
                                          Number_Left_13 = 0
                                          If Mid(Chaine, 14, 1) = Cut(UBound(Cut)) Then
                                             Number_Left_14 = 0
                                             If Mid(Chaine, 15, 1) = Cut(UBound(Cut)) Then
                                                Number_Left_15 = 0
                                                If Mid(Chaine, 16, 1) = Cut(UBound(Cut)) Then
                                                   Number_Left_16 = 0
                                                   If Mid(Chaine, 17, 1) = Cut(UBound(Cut)) Then
                                                      Number_Left_17 = 0
                                                      If Mid(Chaine, 18, 1) = Cut(UBound(Cut)) Then
                                                         Number_Left_18 = 0
                                                         If Mid(Chaine, 19, 1) = Cut(UBound(Cut)) Then
                                                            Number_Left_19 = 0
                                                            If Mid(Chaine, 20, 1) = Cut(UBound(Cut)) Then
                                                               Number_Left_20 = 0
                                                            Else
                                                               Number_Left_20 = Number_Left_20 + 1
                                                            End If
                                                         Else
                                                            Number_Left_19 = Number_Left_19 + 1
                                                         End If
                                                      Else
                                                         Number_Left_18 = Number_Left_18 + 1
                                                      End If
                                                   Else
                                                      Number_Left_17 = Number_Left_17 + 1
                                                   End If
                                                Else
                                                   Number_Left_16 = Number_Left_16 + 1
                                                End If
                                             Else
                                                Number_Left_15 = Number_Left_15 + 1
                                             End If
                                          Else
                                             Number_Left_14 = Number_Left_14 + 1
                                          End If
                                       Else
                                          Number_Left_13 = Number_Left_13 + 1
                                       End If
                                    Else
                                       Number_Left_12 = Number_Left_12 + 1
                                    End If
                                 Else
                                    Number_Left_11 = Number_Left_11 + 1
                                 End If
                              Else
                                 Number_Left_10 = Number_Left_10 + 1
                              End If
                           Else
                              Number_Left_9 = Number_Left_9 + 1
                           End If
                        Else
                           Number_Left_8 = Number_Left_8 + 1
                        End If
                     Else
                        Number_Left_7 = Number_Left_7 + 1
                     End If
                  Else
                     Number_Left_6 = Number_Left_6 + 1
                  End If
               Else
                  Number_Left_5 = Number_Left_5 + 1
               End If
            Else
               Number_Left_4 = Number_Left_4 + 1
            End If
         Else
            Number_Left_3 = Number_Left_3 + 1
         End If
      Else
         Number_Left_2 = Number_Left_2 + 1
      End If
   Else
      Number_Left_1 = Number_Left_1 + 1
   End If
 
Next
 
 
 
Fin = WshShell.Popup("Fin des opérations", 5, "Traitement", 0 + 64)

Et pour calculer le nombre de permutations avec répétition d'une chaîne de caractère :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Set WshShell = WScript.CreateObject("WScript.Shell")
 
Longueur = InputBox("Entrez la longueur du résultat" + vbNewLine + vbNewLine + "Pour des raisons de code et de temps de calcul, vous êtes limité à 10 caratères." + vbNewLine + vbNewLine + vbNewLine + "Les caractères en trop seront tout simplement ignorés des opérations", "Entrée de la longueur du résultat", "3")
If Longueur = "" OR Longueur = "0" Then Erreur = WshShell.Popup("Veuillez entrer une valeur au dessus de 0", 5, "ERROR", 0 + 64) : WScript.Quit 'Si la variable n'a pas de valeur, quitter
Elements = Trim(InputBox("Entrez vos éléments, séparés par des virgules" + vbNewLine + vbNewLine + "Pour des raisons de code et de temps de calcul, vous êtes limité à 10 éléments." + vbNewLine + vbNewLine + vbNewLine + "Les éléments en trop seront tout simplement ignorés des opérations", "Entrée des éléments", "A, B, C"))
If Elements = "" Then Erreur = WshShell.Popup("Veuillez entrer une liste d'éléments" + vbNewLine + "comportant entre 1 et 10 caractères", 5, "ERROR", 0 + 64) : WScript.Quit 'Si la variable n'a pas de valeur, quitter
 
Elements = Replace(Elements, " ", "")
Cut = Split(Elements, ",")
 
resultat = (UBound(Cut) + 1) ^ Longueur
 
Calcul = WshShell.Popup(resultat, 12, "Traitement", 0 + 64)

Fichiers .vbs ci-joints, prêts à l'emploi

Créer un VB Script capable de trouver toutes les permutations avec répétition d'une chaîne String

VBScript

Discussions similaires

Partager

Partager