Discussion :

[fbroillet]

Bonjour,

N'étant pas un expert dans le domaine VB et ayant besoin urgemment d'aide, je me suis dit qu'il ne me restait plus qu'à espérer l'aide d'Internaute !

J'ai un document excel qui fait appel à une macro. Cette macro a différents buts, mais elle doit notamment me permettre de:
1) Créer un tableau de x entiers (x étant par exemple 60) dans l'ordre croissant
2) Reprendre toutes valeurs de ce tableau et me créer un 2ème tableau, mais avec un ordre différent et complètement aléatoire.
3) S'assurer qu'aucune position dans le 1er tableau ne contienne le même entier que dans la même position dans le 2ème tableau.

Voici un extrait du code où je rencontre des problèmes:

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
   For ID = 1 To Nbre_Tapis
        Tableau1(ID) = ID
        Tableau2(ID) = ID
        Tableau3(ID) = ID
        Tableau4(ID) = ID
    Next
 
    v0 = UBound(Tableau2) - LBound(Tableau2)
    For ID = LBound(Tableau2) To UBound(Tableau2)
        v1 = Int(Rnd() * v0 + LBound(Tableau2))
        v2 = Int(Rnd() * v0 + LBound(Tableau2))
        v3 = Tableau2(v2)
        Tableau2(v2) = Tableau2(v1)
        Tableau2(v1) = v3
    Next
    For ID = 1 To Nbre_Tapis
        Set Onglet = Worksheets("Test")
        Onglet.Cells(ID, 1) = Tableau1(ID)
        Onglet.Cells(ID, 2) = Tableau2(ID)
    Next

A la fin je récupère le contenu des 2 tableaux pour les écrire dans mon document Excel et pour valider que ça fonctionne comme attendu. Le contenu de mon premier tableau est parfait (forcément, ça n'est pas bien compliqué), mais le contenu de mon 2ème tableau (tri aléatoire du premier) n'a pas du tout l'effet attendu. Vous verrez ci-dessous que le 2ème tableau me retourner passablement de valeurs nulles ... et je n'ai aucune idée pourquoi !

1
2
3
4
5 21
6
7
8
9
10 28
11 11
12
13
14
15
16
17
18
19 30
20 20
21
22 22
23
24 24
25
26 26
27
28
29
30 23

Sauriez-vous ce qui est faux dans mon code ? Il faudrait à tout prix que je puisse avoir ces 30 valeurs, chacune une seule fois, mais dans un ordre complétement différent.

Quand j'aurai résolu ce problème, je m'attaquerai alors à garantir qu'aucune position dans le 1er tableau ne contienne le même entier que dans la même position dans le 2ème tableau.

Je remercie d'orest déjà tous ceux qui pourrait m'aider et me dire ce que j'ai de faux dans mon bout de code ... le temps presse, du coup je bûche en parallèle pour trouver par moi-même le problème !

Merci d'avance

Fabien

J'oubliais ...

J'ai repris un exemple trouvé sur le net, et j'avoue ne pas comprendre certaines étapes.

Fabien

[mercatog]

Essaies avec celui là

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
Sub Alea()
Const Nb As Integer = 600
Dim i As Integer, j As Integer
Dim Tb(1 To Nb, 1 To 2) As Integer
 
For i = 1 To Nb
    Tb(i, 1) = i
    Tb(i, 2) = i
Next i
 
For i = 1 To Nb
    Do
        j = Int((Nb - 1) * Rnd()) + 1
    Loop Until Tb(j, 2) <> Tb(i, 1)
    Permute Tb, i, j
Next i
Worksheets("Test").Range("A1").Resize(Nb, 2) = Tb
End Sub
 
 
Private Sub Permute(ByRef Tb, ByVal i As Integer, ByVal j As Integer)
Dim Tmp As Integer
 
Tmp = Tb(i, 2)
Tb(i, 2) = Tb(j, 2)
Tb(j, 2) = Tmp
End Sub

[fbroillet]

Merci Mercatog, ça marche à merveille !

J'avais trouvé un moyen dans mon code, mais ça reste bien moins sexy que le tien !

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
  For ID = 1 To 30
        Tableau1(ID) = ID
        Tableau2(ID) = ID
        Tableau3(ID) = ID
        Tableau4(ID) = ID
    Next
    v0 = 30
    For ID = 1 To 30
        v1 = Int(Rnd() * v0 + 1)
        v2 = Int(Rnd() * v0 + 1)
        v3 = Tableau2(v2)
        Tableau2(v2) = Tableau2(v1)
        Tableau2(v1) = v3
    Next
    For ID = 1 To 30
        Set Onglet = Worksheets("Test")
        Onglet.Cells(ID, 1) = Tableau1(ID)
        Onglet.Cells(ID, 2) = Tableau2(ID)
    Next

Comment m'assurer désormais qu'aucune position dans le 1er tableau ne contienne le même entier que dans la même position dans le 2ème tableau (ex: tableau1, indice 9, valeur 18 .... tableau 2, indice 9, valeur 18) ?

[mercatog]

Pour ton code, (en fin de compte quasi identique) mais en utilisant un seul tableau et on y ajoute une boucle Do/ Until pour s'assurer qu'un nombre changera de place

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
Sub TonCode()
Const Nb As Integer = 600
Dim i As Integer, v2 As Integer, v3 As Integer
Dim Tableau(1 To Nb, 1 To 2)
 
For i = 1 To Nb
    Tableau(i, 1) = i
    Tableau(i, 2) = i
Next i
 
For i = 1 To Nb
    Randomize
    'ici on boucle pour s'assurer du changement de place
    Do
        v2 = Int(Rnd() * (Nb - 1) + 1)
    Loop Until Tableau(v2, 2) <> i
 
    v3 = Tableau(v2, 2)
    Tableau(v2, 2) = Tableau(i, 2)
    Tableau(i, 2) = v3
Next
 
Worksheets("Test").Range("A1").Resize(Nb, 2) = Tableau
End Sub

[fbroillet]

Merci Mercatog ...

En fin de compte, j'ai gardé ton bout de code. Il garantit également le changement de position avec la boucle while ?

A+

Maintenant que je n'ai pas une mais 2 versions garantissant les mêmes entiers mais dans un ordre aléatoire et garantissant le changement de position, comment avoir non pas 1 mais 3 tris aléatoires, tout en garantissant qu'un entier n'apparait pas dans la même position dans les 4 cas de figures (liste ordrée et 3 liste aléatoires) ?

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
 
    Dim Tb() As Integer
    Nbre_Tapis = 30
    Dim i As Integer, j As Integer
    ReDim Tb(1 To Nbre_Tapis, 1 To 4) As Integer
    For i = 1 To Nbre_Tapis
        Tb(i, 1) = i
        Tb(i, 2) = i
        Tb(i, 3) = i
        Tb(i, 4) = i
    Next i
 
    For i = 1 To Nbre_Tapis
        'ici on boucle pour s'assurer du changement de place
        Do
            j = Int((Nbre_Tapis - 1) * Rnd()) + 1
        Loop Until Tb(j, 2) <> Tb(i, 1)
        Permute Tb, i, j
    Next i
    Worksheets("Test").Range("A1").Resize(Nbre_Tapis, 4) = Tb

J'ai fait un essai ... mais je ne suis pas sûr que ça garantisse le changement de place dans tous les cas:

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
 Dim i As Integer, j As Integer
    ReDim Tb(1 To Nbre_Tapis, 1 To 4) As Integer
    For i = 1 To Nbre_Tapis
        Tb(i, 1) = i
        Tb(i, 2) = i
        Tb(i, 3) = i
        Tb(i, 4) = i
    Next i
 
    For i = 1 To Nbre_Tapis
        'ici on boucle pour s'assurer du changement de place au 2eme tour
        Do
            j = Int((Nbre_Tapis - 1) * Rnd()) + 1
        Loop Until Tb(j, 2) <> Tb(i, 1)
        Permute Tb, i, j, 2
        'ici on boucle pour s'assurer du changement de place au 3eme tour
        Do
            j = Int((Nbre_Tapis - 1) * Rnd()) + 1
        Loop Until Tb(j, 3) <> Tb(i, 1) And Tb(j, 3) <> Tb(i, 2)
        Permute Tb, i, j, 3
        'ici on boucle pour s'assurer du changement de place au 4eme tour
        Do
            j = Int((Nbre_Tapis - 1) * Rnd()) + 1
        Loop Until Tb(j, 4) <> Tb(i, 1) And Tb(j, 4) <> Tb(i, 2) And Tb(j, 4) <> Tb(i, 3)
        Permute Tb, i, j, 4
    Next i
    Worksheets("Test").Range("A1").Resize(Nbre_Tapis, 4) = Tb
 
Private Sub Permute(ByRef Tb, ByVal i As Integer, ByVal j As Integer, ByVal tour As Integer)
Dim Tmp As Integer
 
Tmp = Tb(i, tour)
Tb(i, tour) = Tb(j, tour)
Tb(j, tour) = Tmp
End Sub

[mercatog]

Générale pour Dm colonnes (attentions quand même, quand Dm est assez grand et Nb petit, l'algorithme diverge facilement: divergence testée pour Dm=5 et Nb=30)

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
Sub Alea()
Const Nb As Integer = 600                          'nombre de lignes
Const Dm As Byte = 4                               'nombre de colonnes
Dim i As Integer, j As Integer
Dim p As Byte
Dim Tb(1 To Nb, 1 To Dm) As Integer
 
For i = 1 To Nb
    For p = 1 To Dm
        Tb(i, p) = i
    Next p
Next i
 
For i = 1 To Nb
    For p = 2 To Dm
        Randomize
        Do
            j = Int((Nb - 1) * Rnd()) + 1
            DoEvents
        Loop Until Not Egaux(Tb, i, j)
        Permute Tb, i, j, p
    Next p
Next i
Worksheets("Test").Range("A1").Resize(Nb, Dm) = Tb
End Sub
 
 
Private Sub Permute(ByRef Tb, ByVal i As Integer, ByVal j As Integer, ByVal k As Byte)
Dim Tmp As Integer
 
Tmp = Tb(i, k)
Tb(i, k) = Tb(j, k)
Tb(j, k) = Tmp
End Sub
 
Private Function Egaux(ByVal Tb, ByVal i As Integer, ByVal j As Integer) As Boolean
Dim m As Byte, n As Byte, p As Byte
 
n = UBound(Tb, 2)
For p = 1 To n
    For m = 1 To n
        If p <> m Then
            If Tb(i, p) = Tb(j, m) Then
                Egaux = True
                Exit Function
            End If
        End If
    Next m
Next p
End Function

[fbroillet]

Salut Mercatog,

C'est tout simplement parfait !

Merci beaucoup pour cette aide si précieuse.

Bonne soirée

fAbien