modifier code vba

[julien clerc]

bonsoir a tous je reviens vers vous pour un nouveau problème
j'ais une vba qui réalise des combinaison de 4 num sur 9 dans tous les ordres
je souhaite modifier on code a fin de supprimer les combinaison croissante ex: 3 6 7 9 = supprimer
en revanche : 3 6 5 9 garder en suite supprimer toute les combin contenant plus de 2 fois le meme numéros ex: 3 6 3 3 = supprimer
voila j’espère avoir était clerc

merci d'avance
Sub combinaisons()
lin = 1
col = 1
For m = 1 To 9
For n = 1 To 9
For o = 1 To 9
For p = 1 To 9
Cells(lin, col) = m & " " & n & " " & " " & o & " " & p
lin = lin + 1
If lin > 10000 Then
col = col + 1
lin = 1
End If

Next p
Next o
Next n
Next m
End Sub

 

[VDAVID]

Re : modifier code vba

Bonjour Julien Clerc,

Peut-être comme ceci:

A copier dans un module, les résultats sont reportés "Feuil1" Range("A1:A4")

Option Base 1
Sub Nb()
 
Dim i, x, z, Valo, m, Lign, Nb As Integer
Dim tabl()
 
x = 9 'Nombre de chiffres possibles
i = 0
ReDim tabl(x)
 
Resetall:

    For m = 1 To x
   
Restart:
 
    Randomize
    Valo = Int((UBound(tabl()) - 1 + 1) * Rnd + 1)
 
        For z = LBound(tabl()) To UBound(tabl())
   
   
            If Valo = tabl(z) Then
                
                If z <> UBound(tabl()) Then
                
                    For Nb = z + 1 To UBound(tabl()) 'Vérification du nombre de répétitions n'exede pas deux
                        
                        If Valo = tabl(Nb) Then
                        GoTo Restart
                        End If
                        
                    Next Nb
                    
                End If
                    
            End If
   
        Next z
 
        i = i + 1
        tabl(i) = Valo
       
    Next m
    
    If tabl(1) < tabl(2) And tabl(2) < tabl(3) And tabl(3) < tabl(4) Then
    Erase tabl()
    GoTo Resetall
    End If
    
    If tabl(1) > tabl(2) And tabl(2) > tabl(3) And tabl(3) > tabl(4) Then
    Erase tabl()
    GoTo Resetall
    End If
 
Sheets("Feuil1").Select ' Nom de la feuille où se placer

    For Lign = 1 To 4 'Ligne où se placer 
    Range("A" & Lign).Value = tabl(Lign) 'Colonne où se placer
    Next Lign
   
    
End Sub

 

[julien clerc]

Re : modifier code vba

bonsoir david ça ne fonctionne pas merci de ton aides

 

[VDAVID]

Re : modifier code vba

Re,

Un fichier exemple,

Chez moi ça marche !

4 chiffres sans plus de deux doublons et pas par ordre croissant.

 

[julien clerc]

Re : modifier code vba

alors je cherche pas un tirage aléatoire , ce que tu propose c'est un tirage de quatre numéros sur neuf aléatoirement ou effectivement les condition imposé sont respecté voila mon code essaye

Sub combinaisons()
lin = 1
col = 1
For m = 1 To 9
For n = 1 To 9
For o = 1 To 9
For p = 1 To 9
Cells(lin, col) = m & " " & n & " " & " " & o & " " & p
lin = lin + 1
If lin > 10000 Then
col = col + 1
lin = 1
End If

Next p
Next o
Next n
Next m
End Sub

 

[VDAVID]

Re : modifier code vba

Re,

Il y'a surement moyen de lisser tout ça, mais en attendant :

Sub combinaisons()
lin = 1
col = 1

    For m = 1 To 9
        
        For n = 1 To 9
            
            For o = 1 To 9
                
                For p = 1 To 9
                
                    If m < n And n < o And o < p Then
                    GoTo Borne
                    End If
                    
                    If m > n And n > o And o > p Then
                    GoTo Borne
                    End If
                        
                    If m = n And n = o Then
                    GoTo Borne
                    End If
                    
                    If m = n And n = p Then
                    GoTo Borne
                    End If
                    
                    If n = o And n = p Then
                    GoTo Borne
                    End If
                    
                    If m = o And o = p Then
                    GoTo Borne
                    End If
                    
                    Cells(lin, col) = m & " " & n & " " & " " & o & " " & p
                    lin = lin + 1
                    
If lin > 10000 Then
col = col + 1
lin = 1
End If

Borne:
Next p
Next o
Next n
Next m
End Sub

A vérifier
Bonne nuit

 

[julien clerc]

Re : modifier code vba

MERCI beaucoup

Cordialement