Créer un tableau 6x6 de nombre de 1 à 6 sans remise Résolu

Question

Bonjour à tous,

Je cherche à créer une petite macro pour un tirage au sort. Il s'agirait de, à partir d'une liste de 6 noms donnés dans des cellules de la première feuille de l'Excel, de créer un tableau 6x6 où chaque colonne reprend une combinaison unique de ces 6 noms classés de façon aléatoire. Concrètement, cela signifie qu'un nom sorti en premier lieu ne peut plus sortir en premier lieu dans les tirages suivants. Un petit exemple vaut mieux qu'un long discours :

Liste des noms :
Marc
André
Joseph
Pierre
Eric
Jean

Le résultat devrait donné :

André       Marc       Joseph       Eric           Jean         Pierre
Marc         Eric         André         Pierre      Joseph     Eric
Jean          Pierre     Eric              Marc       André       Joseph
Joseph     ...
Eric

Dans cet exemple, André a eu la place 1 dans la première colonne. Il ne peut donc se situer qu'aux places allant de 2 à 6 dans les suivantes. Ainsi, chacun ne peut se retrouver qu'une fois à chaque ligne et la dernière colonne ne sera autre que la dernière combinaison possible.

Les tirages doivent être réalisés de façon aléatoire.

Si quelqu'un veut bien me donner un coup de main, je galère depuis toute à l'heure et à chaque fois que je pense avoir la solution quelque chose me bloque...

ccm81 · Accepted Answer

Bonjour

Une solution (laboreiuse)
http://www.cjoint.com/c/FHyrefq3Mqn 

Cdlmnt

InfernoDez · Answer

Solution laborieuse certes, mais surtout rapide et efficace !
En plus, si je lis ton code, il semblerait que ta solution puisse facilement être réutilisé si le nombre de "Participants" devaient varier, ce qui est top.

Merci pour tout en cas !

ccm81 · Answer

De rien

Si c'est fini, peux tu mettre le sujet à résolu (en dessous du titre de ton premier message)

Cdlmnt

pijaku · Answer

Salut,

Salut ccm.

Ayant réalisé également une petite démo, je vous la livre...
    Option Explicit
    
    Sub Appel2()
    Dim montext As String, Resultat As Variant
    
        montext = "Marc;André;Joseph;Pierre;Eric;Jean;Franck;Paul;Francois;sylvie;anne;florence;florient;christophe;sophie;hercule;michel;laurence;renaud;sébastien"
        Resultat = Tout_Alea(montext, ";")
        Range("B1").Resize(UBound(Resultat, 1), UBound(Resultat, 2)) = Resultat
    End Sub
    
    Private Function Tout_Alea(txt As String, sep As String) As Variant()
    Dim TbTemp() As Variant, Spliter As Variant, TbReduit As Variant, dico As Object
    Dim j As Byte, cpt As Byte, col As Byte
    
        'variables et réglages...
        Randomize Timer
        Set dico = CreateObject("scripting.dictionary")
        Spliter = Split(txt, sep)
        ReDim TbTemp(1 To UBound(Spliter) + 1, 1 To UBound(Spliter) + 1)
        'première ligne...
        Do While cpt < UBound(TbTemp, 1)
            j = Int(Rnd * UBound(TbTemp, 1))
            If Not dico.exists(j) Then
                dico(j) = Spliter(j)
                cpt = cpt + 1
                TbTemp(1, cpt) = Spliter(j)
            End If
        Loop
        'par colonnes
        For col = 1 To UBound(TbTemp, 1)
            Spliter = Split(txt, sep)
            TbReduit = Supprime_Index(Spliter, TbTemp(1, col))
            Set dico = CreateObject("scripting.dictionary")
            cpt = 1
            Do While cpt < UBound(TbTemp, 1)
                j = Int(Rnd * (UBound(TbTemp, 1) - 1))
                If Not dico.exists(j) Then
                    dico(j) = TbReduit(j)
                    cpt = cpt + 1
                    TbTemp(cpt, col) = TbReduit(j)
                End If
            Loop
        Next
        Tout_Alea = TbTemp
        'libération de la mémoire
        Erase TbTemp
        Erase Spliter
        Erase TbReduit
        Set dico = Nothing
    End Function

Private Function Supprime_Index(Tableau As Variant, Text_Ou_Index) As Variant
    Dim i As Long, Sucf As String
    '===== le présent code, déposé par ucfoutu sur VBFrance, est la seule propriété de VBFrance
    '=====VBFrance en autorise les libres copie et utilisation à la seule condition d'y laisser
    '=====insérées les trois présentes lignes commentées
        
        If VarType(Text_Ou_Index) = 8 Then
            Sucf = Text_Ou_Index
            i = Retourne_Index(Tableau, Sucf)
        Else
            i = Text_Ou_Index
        End If
        If i >= 0 Then
            Tableau(i) = ""
            Sucf = Join(Tableau, Chr(0))
            If i = 0 Then Sucf = Mid(Sucf, 2)
            If i = UBound(Tableau) Then Sucf = Left(Sucf, Len(Sucf) - 1)
            Supprime_Index = Split(Replace(Sucf, Chr(0) & Chr(0), Chr(0)), Chr(0))
        End If
    End Function
    
    Public Function Retourne_Index(ByVal Tableau As Variant, Texto As String) As Long
    Dim i As Long, strTemp As String
    '===== le présent code, déposé par ucfoutu sur VBFrance, est la seule propriété de VBFrance
    '=====VBFrance en autorise les libres copie et utilisation à la seule condition d'y laisser
    '=====insérées les trois présentes lignes commentées
        strTemp = Chr(0) & Join(Tableau, Chr(0)) & Chr(0)
        i = InStr(strTemp, Chr(0) & Texto & Chr(0))
        If i = 0 Then Retourne_Index = -1: Exit Function
        strTemp = Mid(strTemp, 1, i)
        Retourne_Index = UBound(Split(strTemp, Chr(0))) - 1
        If Retourne_Index < 0 Then Retourne_Index = -1
    End Function

pijaku · Answer

Bonjour,

Une variante plus simple, sur le même thème :
Option Explicit

Sub Essai()
Dim montext As String, Spliter As Variant, TbReduit As Variant, Resultat As Variant, i As Integer

montext = "Marc;André;Joseph;Pierre;Eric;Jean"
    Spliter = Split(montext, ";")
    For i = LBound(Spliter) To UBound(Spliter)
        'première ligne
        Cells(1, i + 4) = Spliter(i)
        'on enlève de l'array le nom inscrit en ligne 1
        TbReduit = Supprime_Index(Spliter, i)
        'on lance la procédure aléa pour la colonne i
        Resultat = Liste_Aleatoire(TbReduit)
        'affichage du résultat
        Cells(2, i + 4).Resize(UBound(Resultat, 1) + 1) = Application.Transpose(Resultat)
    Next
End Sub

Private Function Supprime_Index(ByVal Tableau As Variant, i As Integer) As Variant
Dim Sucf As String
'===== le présent code, déposé par ucfoutu sur VBFrance, est la seule propriété de VBFrance
'=====VBFrance en autorise les libres copie et utilisation à la seule condition d'y laisser
'=====insérées les trois présentes lignes commentées
    Tableau(i) = ""
    Sucf = Join(Tableau, Chr(0))
    If i = 0 Then Sucf = Mid(Sucf, 2)
    If i = UBound(Tableau) Then Sucf = Left(Sucf, Len(Sucf) - 1)
    Supprime_Index = Split(Replace(Sucf, Chr(0) & Chr(0), Chr(0)), Chr(0))
End Function

Function Liste_Aleatoire(ListeNoms As Variant) As Variant()
Dim TbRes() As Variant, Temp As Integer, TbInteg() As Integer
Dim i As Integer, j As Integer, k As Integer
    
    ReDim TbRes(UBound(ListeNoms))
    ReDim TbInteg(UBound(ListeNoms))
    'création liste de nombres qui se suivent
    For i = LBound(ListeNoms) To UBound(ListeNoms)
        TbInteg(i) = i
    Next
    Randomize
    'mélange de la liste des nombres aléatoirement
    k = UBound(ListeNoms) - 1
    For i = LBound(ListeNoms) To UBound(ListeNoms) - 1
        j = Int((k) * Rnd)
        Temp = TbInteg(k + 1)
        TbInteg(k + 1) = TbInteg(j)
        TbInteg(j) = Temp
        k = k - 1
    Next
    'restitution
    For i = LBound(ListeNoms) To UBound(ListeNoms)
        TbRes(TbInteg(i)) = ListeNoms(i)
    Next i
    Liste_Aleatoire = TbRes
    'libération mémoire
    Erase TbInteg
    Erase TbRes
End Function

pijaku · Answer

Salut ccm, 
En effet, j'ai eu la même lecture que toi initialement. Mais à la relecture, dans son exemple, inferno place 2 Eric en seconde ligne. D'où mon code.
Je reviens lundi poster une autre solution avec cette fois toutes les lignes et toutes les colonnes différentes.
Bon week-end à tous

--

pijaku · Answer

Bonjour tout le monde,

Voici la solution tout aléa avec colonnes et lignes sans doublons.
Donc, deux fonctions :
Touille => mélange la "ligne"
Test => vérifie si tout est bon

Les noms sont préalablement saisis dans la feuille active à partir de A1, vers... Ax
Option Explicit
Option Base 1

Sub Noms_Aleatoires()
Dim vElements As Variant, vResults As Variant, i As Integer, j As Integer

vElements = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
    ReDim vResults(1 To UBound(vElements), 1 To UBound(vElements))
    For i = LBound(vElements) To UBound(vElements)
        Do
            vElements = Touille(vElements)
        Loop While Not Test(vElements, vResults, i)
        For j = LBound(vElements) To UBound(vElements)
            vResults(i, j) = vElements(j)
        Next j
    Next
    Cells(1, 3).Resize(UBound(vResults, 1), UBound(vResults, 2)) = vResults
End Sub

Function Test(tb As Variant, TbGeneral As Variant, iCpt As Integer) As Boolean
Dim j As Integer, i As Integer

Test = False
    If iCpt = 1 Then Test = True: Exit Function
    For i = LBound(TbGeneral, 1) To iCpt
        For j = LBound(TbGeneral, 2) To UBound(TbGeneral, 2)
            If tb(i) = TbGeneral(j, i) Then Exit Function
        Next j
    Next i
    Test = True
End Function

Function Touille(ListeNoms As Variant) As Variant()
Dim TbRes() As Variant, Temp As Integer, TbInteg() As Integer
Dim i As Integer, j As Integer, k As Integer
    
    ReDim TbRes(UBound(ListeNoms))
    ReDim TbInteg(UBound(ListeNoms))
    'création liste de nombres qui se suivent
    For i = LBound(ListeNoms) To UBound(ListeNoms)
        TbInteg(i) = i
    Next
    Randomize Timer
    'mélange de la liste des nombres aléatoirement
    k = UBound(ListeNoms) - 1
    For i = LBound(ListeNoms) To UBound(ListeNoms) - 1
        j = Int((k) * Rnd) + 1
        Temp = TbInteg(k + 1)
        TbInteg(k + 1) = TbInteg(j)
        TbInteg(j) = Temp
        k = k - 1
    Next
    'restitution
    For i = LBound(ListeNoms) To UBound(ListeNoms)
        TbRes(TbInteg(i)) = ListeNoms(i)
    Next i
    Touille = TbRes
    'libération mémoire
    Erase TbInteg
    Erase TbRes
End Function

pijaku · Answer

La méthode précédente : ICI
> fait planter Excel
> est trop longue
> utilise trop de mémoire.
 
En voici une nouvelle qui utilise un Tableau d'Objects Dictionary pour tester les colonnes.

Option Explicit
Option Base 1

Sub Avec_Tableau_De_Dictionary()
Dim vElements As Variant, vResults As Variant, i As Long, j As Long
Dim DicoLignes As Object, DicoColonnes() As Object, Test As Boolean

'------ VARIABLES
    Set DicoLignes = CreateObject("scripting.dictionary")
    vElements = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
    If UBound(vElements) > 9 Then
        MsgBox "maximum 9 éléments": Exit Sub
    End If
    ReDim DicoColonnes(UBound(vElements))
    For i = LBound(vElements) To UBound(vElements)
        Set DicoColonnes(i) = CreateObject("scripting.dictionary")
    Next
    ReDim vResults(1 To UBound(vElements), 1 To UBound(vElements))
    
    '------ TRAITEMENT
    For j = LBound(vElements) To UBound(vElements)
    
        'tests :
            'Variable Test AS Boolean = test sur les colonnes
                                        '(variable tableau de dictionary)
            'DicoLignes.Exists = test sur les lignes
        Do
            vElements = Touille(vElements)
            Test = True
            For i = 1 To UBound(vElements)
                If DicoColonnes(i).Exists(vElements(i)) Then
                    Test = False: Exit For
                End If
            Next i
        Loop While DicoLignes.Exists(Join(vElements, ";")) Or Not Test
        
        'remplissage des dictionary pour tests futurs
        For i = LBound(vElements) To UBound(vElements)
            DicoColonnes(i)(vElements(i)) = ""
        Next
        DicoLignes(Join(vElements, ";")) = ""
        
        'remplissage du tableau des résultats
        For i = LBound(vElements) To UBound(vElements)
            vResults(j, i) = vElements(i)
        Next i
    Next j
    '------ RESTITUTION
    Cells(1, 3).Resize(UBound(vResults, 1), UBound(vResults, 2)) = vResults
    
    '------ DESTRUCTION VARIABLES OBJETS
    For i = LBound(vElements) To UBound(vElements)
        Set DicoColonnes(i) = Nothing
    Next
    Set DicoLignes = Nothing
End Sub

Function Touille(ListeNoms As Variant) As Variant()
Dim TbRes() As Variant, Temp As Integer, TbInteg() As Integer
Dim i As Integer, j As Integer, k As Integer
    
    ReDim TbRes(UBound(ListeNoms))
    ReDim TbInteg(UBound(ListeNoms))
    'création liste de nombres qui se suivent
    For i = LBound(ListeNoms) To UBound(ListeNoms)
        TbInteg(i) = i
    Next
    Randomize Timer
    'mélange de la liste des nombres aléatoirement
    k = UBound(ListeNoms) - 1
    For i = LBound(ListeNoms) To UBound(ListeNoms) - 1
        j = Int((k) * Rnd) + 1
        Temp = TbInteg(k + 1)
        TbInteg(k + 1) = TbInteg(j)
        TbInteg(j) = Temp
        k = k - 1
    Next
    'restitution
    For i = LBound(ListeNoms) To UBound(ListeNoms)
        TbRes(TbInteg(i)) = ListeNoms(i)
    Next i
    Touille = TbRes
    'libération mémoire
    Erase TbInteg
    Erase TbRes
End Function
Avant, j'arrivais jamais à finir mes phrases... mais maintenant je

pijaku · Answer

Bonjour,

Une autre solution consiste à penser différemment dès le départ.

La notion d'aléatoire est ici incorrecte.
En effet, un tableau de 6x6 totalement aléatoire autoriserai les doublons jusqu'à même obtenir un tableau de 36 "marc" par exemple.
En ajoutant des conditions, on perd de "l'aléatoire".
J'en veux pour preuve que la dernière ligne (ou dernière colonne, selon...) n'est JAMAIS aléatoire, mais résulte des autres lignes (ou colonnes).

Tout en sachant que le résultat présenté devra être aléatoire tout de même, on peux le "structurer" un peu.

Voici une proposition permettant de ne plus imposer d'autres limites que celles de la feuille Excel elle-même.

1- on mélange la liste des x noms, (=> aléatoire)
ceci nous donne la première ligne du tableau
2- on "décale" les éléments de cette ligne d'une "case" (=> plus aléatoire du tout)
On reproduit sur toutes les lignes.
On obtient ainsi un tableau XxX de données sans doublon ni sur les lignes ni sur les colonnes
3- on intervertie deux par deux quelques lignes et quelques colonnes choisies...aléatoirement! (=> aléatoire)
le choix même de savoir si on intervertie 2 lignes ou 2 colonnes et laissé au hasard...

Le résultat est instantané pour 25 noms avec une "sensation d'aléa" ;-)

Option Explicit
Option Base 1

Sub En_Decalant_Les_Colonnes()
Dim vElements As Variant, vResults As Variant
Dim i As Long, j As Long, Cpt As Long, nbElements As Long

'------------VARIABLES
    vElements = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
    nbElements = UBound(vElements)
    ReDim vResults(1 To nbElements, 1 To nbElements)
    
    '------------MELANGE LES NOMS
    vElements = Touille(vElements)
    For j = 1 To nbElements
        '1ère ligne => pas de décalage
        'lignes suivantes => décalage
        If j > 1 Then vElements = Decale(vElements, 1)
        For i = 1 To nbElements
            vResults(j, i) = vElements(i)
        Next i
    Next j
    
    '------------INTERVERTIE DES LIGNES OU DES COLONNES
    Randomize Timer
    Do
        Cpt = Cpt + 1
        j = Int((nbElements) * Rnd) + 1
        Do
            i = Int((nbElements) * Rnd) + 1
        Loop While i = j
        vResults = Swap(vResults, j, i, CBool(Round(Rnd)))
    Loop While Cpt < nbElements
    
    '------------RESTITUTION
    Cells(1, 3).Resize(UBound(vResults, 1), UBound(vResults, 2)) = vResults
End Sub

Private Function Touille(ListeNoms As Variant) As Variant()
Dim TbRes() As Variant, Temp As Long, TbInteg() As Long
Dim i As Long, j As Long, k As Long
    
    ReDim TbRes(UBound(ListeNoms))
    ReDim TbInteg(UBound(ListeNoms))
    'création liste de nombres qui se suivent
    For i = LBound(ListeNoms) To UBound(ListeNoms)
        TbInteg(i) = i
    Next
    Randomize Timer
    'mélange de la liste des nombres aléatoirement
    k = UBound(ListeNoms) - 1
    For i = LBound(ListeNoms) To UBound(ListeNoms) - 1
        j = Int((k) * Rnd) + 1
        Temp = TbInteg(k + 1)
        TbInteg(k + 1) = TbInteg(j)
        TbInteg(j) = Temp
        k = k - 1
    Next
    'restitution
    For i = LBound(ListeNoms) To UBound(ListeNoms)
        TbRes(TbInteg(i)) = ListeNoms(i)
    Next i
    Touille = TbRes
    'libération mémoire
    Erase TbInteg
    Erase TbRes
End Function

Private Function Decale(Tableau As Variant, lDecalage As Long) As Variant
Dim i As Long, j As Long, tb() As Variant

ReDim Preserve tb(UBound(Tableau))
    j = LBound(Tableau)
    For i = LBound(Tableau) To UBound(Tableau)
        If j + lDecalage > UBound(Tableau) Then j = 0
        tb(i) = Tableau(j + lDecalage)
        j = j + 1
    Next
    Decale = tb
    Erase tb
End Function

Private Function Swap(Tableau As Variant, iCol As Long, jCol As Long, byColumn As Boolean) As Variant
Dim i As Long, j As Long, tb As Variant
    tb = Tableau
    If byColumn Then
        For i = 1 To UBound(tb, 1)
            tb(i, iCol) = Tableau(i, jCol)
            tb(i, jCol) = Tableau(i, iCol)
        Next i
    Else
        For i = 1 To UBound(tb, 2)
            tb(iCol, i) = Tableau(jCol, i)
            tb(jCol, i) = Tableau(iCol, i)
        Next i
    End If
    Swap = tb
    Erase tb
End Function

Je pense que l'on peux en rester là...pour le moment ;-))

ccm81 · Answer

Re

C'est marrant, cest la première solution que j'avais envisagée ... avant de la trouver moyennement aléatoire
http://www.cjoint.com/c/FHFmbwJbEXn 

Bonne journée

Créer un tableau 6x6 de nombre de 1 à 6 sans remise

10 réponses

Votre réponse

Discussions similaires

Newsletters