Discussion :

[gaetanos]

Bonjour à tous,

Je débute en VBA et Macro, après des recherches sur les différents forum j'ai réussi à créer la fonction dont j'ai besoin (fichier joint) :

- générer des nombres entiers de 1 à 20 sans doublons de façon aléatoire et sous forme de tableau, le tout répété 4 fois ce qui me donne un tableau de 20 colonnes (5 colonnes par répétion) et 5 lignes.

Dans cette configuration il existe encore des doublons par lignes, je pense utiliser une "boucle avec condition" pour que la macro tourne et s'arrête au moment au il n'y plus de doublons (que ce soit pour les lignes ou les colonnes) mais je n'arrive pas à réaliser cette opération.

D'avance merci pour vos réponses

Gaétan

[Gado2600]

Bonjour,

Effectivement, utiliser une boucle peut être pas mal.

Pour gérer ton problème de doublons, la première idée qui me vient à l'esprit est d'utiliser un tableau numérique comme ceci :

Code :

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

1
2
3
4
5
dim tabA()   as variant
redim tabA(1 to 20)
for i = lbound(tabA) to ubound(tabA)
       tabA(i)=false
next

Le code ci-dessus initialise un tableau de la dimension qui correspond aux nombres que tu veux sortir.
Le but ici, c'est lors de la création de l'un de tes blocs, tu vas appliquer ton random de 1 à 20 et stocké la valeur dans une variable.
Tu vérifies ensuite si ta valeur est déjà utilisée ou non. Exemple :

Code :

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

1
2
3
4
5
6
dim intVar as integer 
intVar = 2
while tabA(intVar) = true 
       intVar = autre valeur
wend
rng = intVar ' écriture

Ensuite, sur chaque bloc, tu réinitialises ton tableau et tu recommences le procédé à chaque fois :

Code :

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

1
2
3
4
Pour chaque bloc
       Initialisation du tableau (code 1)
       Recherche et inscription des valeurs (code 2)
Fin pour

Cordialement,

[vinc_bilb]

Bonjour,

Par rapport à la proposition de Gado2600, je propose une toute petite alternative pour la partie détection des valeurs en doublon et remplacement.
Schématiquement:
- On génère le tableau comme indiqué
- Sachant qu'il doit contenir toutes les valeurs 1 à 20, on remplace les valeurs en doublon par celles manquantes: c'est beaucoup plus rapide

Ci-joint un cas réel que j'avais utilisé pour générer des tables de hash de Pearson

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
Sub Gener_Pears_Arr()
' Generate a table based on Nb of bits (user input)
 
Subname = "Gener_Pears_Arr"
 
Dim BitN As Integer
Dim Msganswer As String
Dim Pears_CrInd As Double, Pears_Ind As Double, Pears_Corr As Double
Dim MinVal As Integer, MaxVal As Double, RndVal As Double
Dim ExistVal As Boolean, ValidVal As Boolean
Dim Pears_arr() As Double
 
ThisWorkbook.Activate
 
On Error GoTo Err_Gener_Pears_Arr
 
    ' Number of bits input and value min (0 or 1)
While BitN = 0 Or MinVal > 1
    BitN = Application.InputBox("Nb of bits: ", Subname, Type:=1)
    MinVal = Application.InputBox("Minimum value (and index): ", Subname, Default:=0, Type:=1)
Wend
 
If BitN >= 14 Then MsgBox "Process could be long.... Be patient!", , Subname
 
 
    ' Set the parameters of the table
MaxVal = 2 ^ BitN - 1 + MinVal
 
ReDim Pears_arr(MinVal To MaxVal, 1 To 2)
 
    ' Create the table without check of the unicity
For Pears_Ind = MinVal To MaxVal
 
    Randomize
    RndVal = Int((MaxVal - MinVal + 1) * Rnd + MinVal)
    Pears_arr(Pears_Ind, 1) = RndVal
    Pears_arr(RndVal, 2) = Pears_arr(RndVal, 2) + 1
 
Next Pears_Ind
 
    'Now, parse the table and detect the records which have been assigned several times
For Pears_Ind = MinVal To MaxVal
 
        ' More than one assignation
    If Pears_arr(Pears_Ind, 2) > 1 Then
        'Debug.Print Pears_Ind, Pears_arr(Pears_Ind, 2)
 
            ' Search for the first record having this value
 
        For Pears_CrInd = MinVal To MaxVal
 
            If Pears_arr(Pears_CrInd, 1) = Pears_Ind Then
                'Debug.Print Pears_CrInd, Pears_arr(Pears_CrInd, 1)
 
                For Pears_Corr = MinVal To MaxVal
 
                    If Pears_arr(Pears_Corr, 2) = 0 Then
 
                        Pears_arr(Pears_CrInd, 1) = Pears_Corr
                        Pears_arr(Pears_Ind, 2) = Pears_arr(Pears_Ind, 2) - 1
                        Pears_arr(Pears_Corr, 2) = Pears_arr(Pears_Corr, 2) + 1
 
                        Exit For
 
                    End If
 
                Next Pears_Corr
 
            End If
 
        If Pears_arr(Pears_Ind, 2) = 1 Then Exit For
 
        Next Pears_CrInd
 
    End If
 
 
Next Pears_Ind

[mercatog]

Ma proposition (algorithme diverge mais contourné)

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
Option Explicit
 
Const S As Byte = 5
 
Sub Test()
 
GenereSerieAleatoireSansDoublons 20, Range("B2")
End Sub
 
 
Private Sub GenereSerieAleatoireSansDoublons(ByRef Nb As Long, Dest As Range)
Dim i As Integer, R As Integer, j As Integer, m As Integer, q As Integer, Tb() As Integer
Dim P() As String, L() As String
Dim k As Byte
Dim H
 
Application.StatusBar = "Recherche combinaisons en cours..."
Nb = S * (Nb \ S)
Dest.Resize(Nb / S, Nb).ClearContents
ReDim Tb(1 To Nb / S, 1 To Nb)
ReDim L(1 To Nb)
ReDim P(1 To Nb / S)
 
For k = 1 To Nb / S
    i = 1
    Do
        DoEvents
        R = NUMERO(Nb, P, L, i, k)
 
        j = 1 + (i - 1) \ S
 
        If R = 0 Then
            If k > 1 Then
                For q = 1 To Nb / S
                    H = Split(P(q), ",")
                    P(q) = ""
                    For m = 0 To S * (k - 1)
                        If H(m) <> "" Then P(q) = P(q) & "," & H(m)
                    Next m
                Next q
 
                For m = 1 To Nb
                    Tb(k, i) = Empty
                Next m
 
                L(k) = ""
                i = 1
            End If
        Else
            P(j) = P(j) & "," & R
            L(k) = L(k) & "," & R
            Tb(k, i) = R
            i = i + 1
        End If
    Loop While i <= Nb
Next k
Dest.Resize(Nb / S, Nb).Value = Tb
Application.StatusBar = False
End Sub
 
Private Function NUMERO(ByVal Nb As Long, ByVal P, ByVal L, ByVal i As Integer, ByVal k As Byte) As Integer
Dim R As Integer
Dim Cp As Long
 
Randomize
Do
    DoEvents
    R = Int(Nb * Rnd()) + 1
    Cp = Cp + 1
    If Cp > 200 Then Exit Function
Loop Until Not DEJAP(P, R, i) And Not DEJAL(L, R, k)
NUMERO = R
End Function
 
 
Private Function DEJAP(ByVal vP, ByVal vR As Long, ByVal i As Long) As Boolean
Dim k As Long
 
k = 1 + (i - 1) \ S
DEJAP = InStr(vP(k) & ",", "," & CStr(vR) & ",")
End Function
 
Private Function DEJAL(ByVal vL, ByVal vR As Long, ByVal k As Long) As Boolean
 
DEJAL = InStr(vL(k) & ",", "," & CStr(vR) & ",")
End Function