Générer un tableau d'astreinte 10 pers sur un roulement de 8 sans doublon

Bonjour,

Je sollicite votre aide pour créer une macro afin de générer une liste de nom aléatoire sur un roulement de 8 choix pour 10 personnes sans doublon. :)

J'ai tenté de réaliser une formule mais ça a été un lamentable échec. Je pense que la macro peut-être ma solution mais je n'ai pas de maîtrise en VBA. J'ai regardé quelques lignes de code mais très difficile de les déchiffrer et de les transposer à mon besoin. :(

Pour donner plus de détails à ma demande :

- Nous avons 10 personnes inscrites pour des astreintes (colonne A)

- Si la personne désignée en astreinte ne réponds pas ou a besoin d'aide, elle sollicite la personne en 1er choix, puis selon le besoin ou si personne ne réponds pas, la 2ème est contactée, etc. (C3:Q3)

Je souhaiterais que la macro inscrive les noms dans les 8 colonnes de façon aléatoire et sans doublon ni en ligne et ni en colonne en face de chaque personne inscrite en astreinte.

Merci par avance de votre aide.

Nathalie

Bonjour Nathalie,

J'ai supprimer les colonnes vides car le code serait encore plus compliqué. (On peut aussi ajouter en fin de code l'ajout de colonnes vides mais je ne l'ai pas fait). Donc on travaille à partir de la colonne A et on alimente la plage B3:I12. Renommez l'onglet votre selon vos besoins, pour ma part je l'ai nommé "ASTREINTE".

Sub Astreintes_Aleatoires()
    Dim ws As Worksheet
    Dim arr As Variant
    Dim i As Long, j As Long
    Dim dict As Object
    Dim keys As Variant
    Dim col As Long

    ' Définir la feuille de calcul
    Set ws = ThisWorkbook.Sheets("ASTREINTE")

    'Récupère les données dans un tableau
    arr = ws.Range("A3:A12").Value

    ' Efface la plage B3:I12
    ws.Range("B3:I12").ClearContents

    ' Création d'un dictionnaire pour garantir des affectations uniques
    Set dict = CreateObject("Scripting.Dictionary")

    ' Initialise le dictionnaire
    For i = LBound(arr) To UBound(arr)
        dict(arr(i, 1)) = ""
    Next i

    ' Attribue des noms au hasard sans doublons
    For col = 2 To 9 ' Columns B to I
        keys = dict.keys
        For i = LBound(arr) To UBound(arr)
            Do
                j = Int((UBound(keys) + 1) * Rnd)
            Loop While keys(j) = "" Or keys(j) = arr(i, 1)
            ws.Cells(i + 2, col).Value = keys(j)
            keys(j) = ""
        Next i
    Next col
End Sub

Bonjour Et1000lio,

Je vous remercie pour votre code et pour votre super réactivité :)

J'ai supprimé les colonnes vides et renommé la feuille "ASTREINTE" comme vous l'avez suggéré. Toutefois, le code plante au moment de la boucle For après le Do J=.... Si je n'appuie pas sur la touche Echap, l'Excel plante complètement.

Est ce que vous pourriez m'expliquer la traduction de ce code, svp ? j = Int((UBound(keys) + 1) * Rnd)

Merci pour votre aide.

Nathalie

Bonjour Nathalie,

Code modifié. Ci joint le fichier

Bonjour Et1000lio,

Ah parfait, il ne plante plus et le code est super fluide. Top.

Par contre, je suis désolée de t'embêter à nouveau, :( mais j'ai des doublons de noms en ligne et colonne. Est ce qu'il serait possible d'avoir des valeurs uniques en ligne et colonne en excluant le nom de la personne en astreinte (colonne A) sur la ligne concerné de cette même personne ?

Merci encore.

Nathalie

Ha ! effectivement... il y a des doublon dans les colonnes. Je te propose une macro un peu plus longue à générer sur la base du carré Latin car je ne vois pas d'autre solution.

Ce code crée un carré latin en décalant les noms dans chaque ligne. Par exemple, si vos noms sont [A, B, C, D, E, F, G, H, I, J], alors la première ligne sera [A, B, C, D, E, F, G, H, I, J], la deuxième ligne sera [J, A, B, C, D, E, F, G, H, I], la troisième ligne sera [I, J, A, B, C, D, E, F, G, H], et ainsi de suite.

Sub CARRE_LATIN()
    Dim ws As Worksheet
    Dim arr As Variant
    Dim i As Long, j As Long
    Dim temp As Variant

 Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Sheets("ASTREINTE")

    arr = ws.Range("A3:A12").Value

    ws.Range("B3:I12").ClearContents

    For i = LBound(arr) To UBound(arr)
        For j = 1 To 8
            ws.Cells(i + 2, j + 1).Value = arr((i + j - 1) Mod UBound(arr) + 1, 1)
        Next j
    Next i
     Application.ScreenUpdating = True
End Sub

Ouah au top vous m'impressionnez !

Je peux dire que le sujet est clos.

Merci infiniment.

Belle journée à vous.

Nathalie

bonjour Nath-eel, et1000lio,

je ne vois pas la réponse sur ceci "Si la personne désignée en astreinte ne réponds pas ou a besoin d'aide, elle sollicite la personne en 1er choix, puis selon le besoin ou si personne ne réponds pas, la 2ème est contactée, etc. (C3:Q3)". Ces besoignes se trouvent où ?