XL 2021 Panning de 8 conseillers en insertion pour visites a domicile sur 4 secteurs en binome

Sub square()
    Const n& = 8
    Dim a, b, c(), arr
    Dim i, u, v, w, x, j

    ' Tableau associant les nombres aux prénoms
    arr = Array("Laure", "Sophie", "Claude", "Michel", "Zoe", "Xavier", "Max", "Clara")
   
    ' Initialisation des tableaux
    ReDim c(1 To n, 1 To n)
    a = Evaluate("row(1:" & n & ")"): b = a

    ' Mélange aléatoire des rangées et des colonnes
    Randomize
    For i = 1 To n
        u = Int(Rnd * (n - i + 1)) + i
        v = Int(Rnd * (n - i + 1)) + i
        w = a(i, 1): a(i, 1) = a(u, 1): a(u, 1) = w
        w = b(i, 1): b(i, 1) = b(v, 1): b(v, 1) = w
    Next i

    ' Construction du carré latin
    For j = 1 To n
        For i = 1 To n
            x = a(i, 1) + j - 1
            If x > n Then x = x - n
            ' Remplacement du numéro par le prénom correspondant
            c(i, a(j, 1)) = arr(b(x, 1) - 1) ' Utilisation de b(x, 1) pour indexer arr
        Next i
    Next j

    ' Affichage du carré latin dans la feuille Excel
    Range("B2").Resize(n, n).Value = c
End Sub

Sub MultiSquareWithNames()
    Const n& = 8 ' Taille du carré latin (8x8)
    Dim a, b, c()
    Dim i, u, v, w, x, j, k As Long
    Dim startRow As Long
    Dim arr As Variant
    
    ' Tableau des prénoms correspondant aux nombres 1 à 8
    arr = Array("Laure", "Sophie", "Claude", "Michel", "Zoe", "Xavier", "Max", "Clara")
    ReDim c(1 To n, 1 To n) ' initialisation de la matrice c
    ' Boucle principale pour générer 5 carrés latins
    For k = 0 To 4
        startRow = 2 + k * (n + 2) ' Position de départ pour chaque carré latin
                                   ' Espacement de 2 lignes
        a = Evaluate("row(1:" & n & ")"): b = a ' Initialisation des lignes et colonnes

        ' Mélange aléatoire des lignes et colonnes
        Randomize
        For i = 1 To n
            u = Int(Rnd * (n - i + 1)) + i
            v = Int(Rnd * (n - i + 1)) + i
            w = a(i, 1): a(i, 1) = a(u, 1): a(u, 1) = w
            w = b(i, 1): b(i, 1) = b(v, 1): b(v, 1) = w
        Next i

        ' Construction du carré latin avec des prénoms
        For j = 1 To n
            For i = 1 To n
                x = a(i, 1) + j - 1
                If x > n Then x = x - n
                ' Remplacement du numéro par le prénom correspondant dans le tableau arr
                c(i, a(j, 1)) = arr(b(x, 1) - 1)
            Next i
        Next j

        ' Affichage du carré latin dans la feuille Excel
        Range("B" & startRow).Resize(n, n).Value = c
    Next k
End Sub

Sub GenerateSquareLatin()
    Dim ws As Worksheet
    Dim n As Long
    Dim a, b, c()
    Dim names As Variant
    Dim i, u, v, w, x, j As Long

    ' Référence à la feuille 1
    Set ws = ThisWorkbook.Sheets("Feuil1")
    
    ' Lecture de la liste des noms dans la colonne A
    names = Application.Transpose(ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row).Value)
    
    ' Nombre de noms trouvés
    n = UBound(names) - LBound(names) + 1
    If n < 2 Then
        MsgBox "Il faut au moins 2 noms dans la colonne A pour générer un carré latin.", vbExclamation
        Exit Sub
    End If

    ' Initialisation des tableaux
    ReDim c(1 To n, 1 To n)
    a = Evaluate("row(1:" & n & ")"): b = a

    ' Mélange aléatoire des rangées et des colonnes
    Randomize
    For i = 1 To n
        u = Int(Rnd * (n - i + 1)) + i
        v = Int(Rnd * (n - i + 1)) + i
        w = a(i, 1): a(i, 1) = a(u, 1): a(u, 1) = w
        w = b(i, 1): b(i, 1) = b(v, 1): b(v, 1) = w
    Next i

    ' Construction du carré latin
    For j = 1 To n
        For i = 1 To n
            x = a(i, 1) + j - 1
            If x > n Then x = x - n
            ' Attribution des noms dans la grille
            c(i, a(j, 1)) = names(b(x, 1))
        Next i
    Next j

    ' Affichage du carré latin dans la feuille à partir de C1
    ws.Range("C1").Resize(n, n).Value = c

    ' Message de confirmation
    MsgBox "Carré latin généré avec succès à partir de la liste dans la colonne A.", vbInformation
End Sub