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

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

    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

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

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

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