Répartition d'équipe hebdomadaire annuelle et aléatoire

**Monda** · 24/10/2020, 23h12

Bonjour à vous tous,

Je me débrouille sur Excel au travers de tutos et d’exercices, mais voilà je sèche là, malgré mes recherches.
Je souhaite créé un planning aléatoire sur une année, avec des binômes, avec le moins de redondance possible et avec une exception.

Je m’explique :
Chaque équipe est composée des mêmes personnes
Toutes les personnes en HS peuvent-être en Astreinte sauf la 1 : BS en rouge
Toutes les personnes peuvent-être en Astreinte en même temps qu’en Heures Suppe sauf la 6 : BA.

Les Heures Supp sont en Binôme, 2 personnes à chaque fois.
Seul 1 : BS, ne fait pas d’Heures Supp, mais fait des astreintes

Les Astreinte sont seules, 1 personne à chaque fois.
Seul 6 : BA, ne fait pas d’Astreinte, mais fait des Heures Supp.

1fois / semaine le tout en même temps sur 52 semaines, en répartissant les charges à parts égales le mieux possible

Equipe de base :

Equipe HS	Equipe Binôme HS	Equipe Astreinte
1 : BS	1 : BS	1 : BS
2 : GC	2 : GC	2 : GC
3 : ZA	3 : ZA	3 : ZA
4 : MS	4 : MS	4 : MS
5 : JL	5 : JL	5 : JL
6 : BA	6 : BA	6 : BA
7 : BL	7 : BL	7 : BL

Exemple recherché :
Semaine 1 :

Equipe HS :	Equipe Binôme HS :	Equipe Astreinte :
4 : MS	5 : JL	5 : JL
6 : BA	3 : ZA	3 : ZA
7 : BL	2 : GC	2 : GC
3 : ZA	4 : MS	4 : MS
6 : BA	7 : BL	7 : BL
2 : GC	5 : JL	1 : BS

Semaine 2:

Equipe HS :	Equipe Binôme HS :	Equipe Astreinte :
4 : MS	3 : ZA	3 : ZA
6 : BA	2 : GC	2 : GC
7 : BL	4 : MS	4 : MS
3 : ZA	6 : BA	1 : BS
2 : GC	5 : JL	5 : JL
5 : JL	7 : BL	7 : BL

Déjà comme ça avec 2 semaines je louche, auriez-vous une solution?

Merci de m’avoir lu, en espérant avoir une réponse favorable .
Belle soirée à vous tous
Sylvain

**ARTURO83** · 26/10/2020, 08h27

Bonjour,

Proposition sur 53 semaines, environ 13000 combinaisons testées en quelques secondes
Pièce jointe 582222

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
    Dim i As Long, j As Long, k As Long
    Dim Lig As Long, C1 As Long, C2 As Long, C3 As Long
    Dim DerLig As Long, DerLig_Pleine As Long
    Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long, n As Long, L1 As Long, L2 As Long
    Dim A1 As Long, A2 As Long, A3 As Long, A4 As Long, A5 As Long, A6 As Long, A7 As Long
    Dim Cpt As Double
    Dim Deb As Double
 
Sub Combinaisons_et_TirageAleatoire()
    Deb = Timer
    Application.ScreenUpdating = False
    C1 = 15
    C2 = 16
    C3 = 17
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    For n = 1 To 2
        Range("B2:I" & DerLig).ClearContents
        Lig = 2
 
        'Combinaisons
        For i = 2 To 7
            For j = i + 1 To 7
                If j = 9 Then j = 2
                For k = 2 To 7
                    If Cells(i, C1) <> 1 And Cells(j, C2) <> 1 And Cells(k, C3) <> 6 And Cells(i, C1) <> Cells(j, C2) Then
                        Range(Cells(Lig, "E"), Cells(Lig, "G")) = Array(Cells(i, C1), Cells(j, C2), Cells(k, C3))
                        Lig = Lig + 1
                    End If
                Next k
            Next j
        Next i
    Next n
 
Construction:
    'Construction par semaine
    Construction_Par_Semaine
 
    'Remplacement des N° par les affectations
    For i = 1 To 7
        Affect = Cells(i + 10, "T")
        Range("B2:D" & DerLig).Replace What:=i, Replacement:=Affect, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Next i
 
    'on reproduit le cycle pour les semaines manquantes, mais en permutant les colonnes B et C
    DerLig_Pleine = Range("B" & Rows.Count).End(xlUp).Row
    Range("B" & DerLig_Pleine + 1 & ":B" & DerLig).FormulaR1C1 = "=R[-" & DerLig_Pleine - 1 & "]C[1]"
    Range("C" & DerLig_Pleine + 1 & ":C" & DerLig).FormulaR1C1 = "=R[-" & DerLig_Pleine - 1 & "]C[-1]"
    Range("D" & DerLig_Pleine + 1 & ":D" & DerLig).FormulaR1C1 = "=R[-" & DerLig_Pleine - 1 & "]C"
    Range("B2:D" & DerLig).Value = Range("B2:D" & DerLig).Value
    Range("E2:J" & DerLig).ClearContents
    MsgBox "Durée: " & Timer - Deb & " Sec" & Chr(10) & Cpt & "Combinaisons parcourues"
End Sub
 
Sub Construction_Par_Semaine()
    Cpt = 0
    Range("O11:Q18").ClearContents
    i = 2
    Randomize
    For a = 2 To 31
        Range(Cells(11, "O"), Cells(11, "Q")).Value = Range(Cells(a, "E"), Cells(a, "G")).Value
        For b = 32 To 55
            Range(Cells(12, "O"), Cells(12, "Q")).Value = Range(Cells(b, "E"), Cells(b, "G")).Value
            For c = 56 To 73
                Range(Cells(13, "O"), Cells(13, "Q")).Value = Range(Cells(c, "E"), Cells(c, "G")).Value
                For d = 74 To 85
                    Range(Cells(14, "O"), Cells(14, "Q")).Value = Range(Cells(d, "E"), Cells(d, "G")).Value
                    For e = 86 To 91
                        Range(Cells(15, "O"), Cells(15, "Q")).Value = Range(Cells(e, "E"), Cells(e, "G")).Value
                        Cpt = Cpt + 1
Cherche:
                        f = Int((90 * Rnd) + 1) + 1
                        Range(Cells(16, "O"), Cells(16, "Q")).Value = Range(Cells(f, "E"), Cells(f, "G")).Value
                        'si il y a 2 journées identiques, on refait une recherche aléatoire
                        If Cells(16, "N") = Cells(11, "N") Or Cells(16, "N") = Cells(12, "N") Or Cells(16, "N") = Cells(13, "N") Or _
                            Cells(16, "N") = Cells(14, "N") Or Cells(16, "N") = Cells(15, "N") Then GoTo Cherche
                        A1 = Application.CountIf(Range("O11:Q16"), 1)
                        A2 = Application.CountIf(Range("O11:Q16"), 2)
                        A3 = Application.CountIf(Range("O11:Q16"), 3)
                        A4 = Application.CountIf(Range("O11:Q16"), 4)
                        A5 = Application.CountIf(Range("O11:Q16"), 5)
                        A6 = Application.CountIf(Range("O11:Q16"), 6)
                        A7 = Application.CountIf(Range("O11:Q16"), 7)
                        'on ne conserve le résultat que si chaque employé ne soit pas présent plus de 3 fois dans la semaine et que tous soient présent au moins 1 fois
                        If Application.Max(A1, A2, A3, A4, A5, A6, A7) <= 3 And Application.Min(A1, A2, A3, A4, A5, A6, A7) <> 0 Then
                            L1 = Int((5 * Rnd) + 1) + 10
                            L2 = Int((5 * Rnd) + 1) + 10
                            Do While L1 = L2
                                L2 = Int((5 * Rnd) + 1) + 10
                            Loop
                            'on permute les lignes L1 et L2 pour obtenir un effet aléatoire
                            Range(Cells(18, "O"), Cells(18, "Q")).Value = Range(Cells(L1, "O"), Cells(L1, "Q")).Value
                            Range(Cells(L1, "O"), Cells(L1, "Q")).Value = Range(Cells(L2, "O"), Cells(L2, "Q")).Value
                            Range(Cells(L2, "O"), Cells(L2, "Q")).Value = Range(Cells(18, "O"), Cells(18, "Q")).Value
                            Range(Cells(i, "B"), Cells(i + 5, "D")).Value = Range("O11:Q16").Value
                            Range("O11:Q18").ClearContents
                            i = i + 6
                            GoTo Suivant_a
                        End If
Suivant_e:
                    Next e
Suivant_d:
                Next d
Suivant_c:
            Next c
Suivant_b:
        Next b
Suivant_a:
    Next a
End Sub

Cdlt

**Monda** · 26/10/2020, 15h27

Bonjour Arturo,
Ça me fait plaisir de vous retrouver. Franchement je suis sans voix…
A priori vous avez tout compris. INCROYABLE, votre tableau.

Serait-il possible d'y ajouter une règle éviter de retrouver les équipes en HS plusieurs fois à la suite?
Je vous joint un fichier Excel ou j'i essayé d'expliquer tout ça…

Merci à vous en tout cas.
Sylvain
PS : Dans votre petit tableau répartition semaine il ne s'affiche rien chez moi Normal??

**ARTURO83** · 26/10/2020, 16h11

Bonjour,

Serait-il possible d'y ajouter une règle éviter de retrouver les équipes en HS plusieurs fois à la suite?

Je vais regarder voir comment m'y prendre, mais ça risque de prolonger le temps d'exécution.

Dans votre petit tableau répartition semaine il ne s'affiche rien chez moi Normal??

Oui, il ne sert qu'à préparer les semaines, après chaque semaine complète trouvée, le contenu du tableau est effacé pour calculer la semaine suivante, donc c'est normal qu'à la fin il n'y ait plus rien.

Quelques explications sur le principe de fonctionnement:
Il y a 6 employés HeuresSUp (Hs) et 6 employés Astreintes (Ast):
Chaque Hs peut être en binôme avec les 5 autres, ainsi qu'avec les 6 Ast, ce qui fait pour 6 x 5 x 6 = 180 combinaisons or, comme un HS peut-être indifféremment en colonne B ou colonne C, on divise par deux les combinaisons pour éviter d'avoir des doublons. Les résultats obtenus sont collés dans le tableau E2:G91.
Partant de là, on va construire les semaines
on prend la première ligne du tableau "E2:G31" qu'on copie dans O11:Q11 (1er jour de la semaine)
on prend la première ligne du tableau "E32:G55" qu'on copie dans O12:Q12 (2ème jour de la semaine)
on prend la première ligne du tableau "E56:G73" qu'on copie dans O13:Q13 (3ème jour de la semaine)
on prend la première ligne du tableau "E74:G85" qu'on copie dans O14:Q14 (4ème jour de la semaine)
on prend la première ligne du tableau "E86:G91" qu'on copie dans O15:Q15 (5ème jour de la semaine)
Le 6ème jour est pris aléatoirement dans le tableau E2:G91, si le choix est déjà pris on refait un tirage aléatoire qu'on copie dans O16:Q16 (6ème jour de la semaine)

Tout au long du remplissage du tableau O11:Q16, s'il y a un employé utilisé plus de 3 fois ou qu'un des employés n'a pas été utilisé, alors on refait une recherche aléatoire.
Si tous les critères ne sont pas réunis alors, on prend une autre ligne du tableau E2:G91 et on refait le test, si tout est épuisé on prend une autre ligne du tableau E74:G85, et ainsi de suite sur toutes les lignes du tableau E2:G91 de telle sorte qu'ion balaye tous les cas de figure, soit un nombre de combinaisons égal à: 30 x 24 x 18 x 12 x 6 = 933120 combinaisons.

Si tous les critères sont bons pour valider la semaine, et avant de la recopier fans le tableau principal en B2:D319, on permute 2 journées pour accentuer l'effet alétoire.
C'est lorsque tous les critères sont réunis que la semaine est validée et recopiée dans le tableau principal en B2:D319, et on continu les tests pour traiter de la semaine suivante.

Cdlt

**Monda** · 26/10/2020, 17h36

Bonsoir Arturo,
Merci à vous… en tout cas.
Pour simplifier peut-être ne faites que sur 3 ou 6 mois, si cela vous facilite les calculs.
De plus il y aura certaines fois ou je devrais le faire à la main, les vacances, les absences etc.
C'est surtout quand je le fais moi-même au bout de 2 semaines c'est un vrai casse têtes chinois.

Je dois surtout en fin d'année faire en sorte que chacun ait fait autant d'heures supp que les autres plus ou moins et idem pour les astreintes.
Merci encore
Sylvain

**ARTURO83** · 27/10/2020, 04h03

Bonjour,

Voici une autre version, plus rapide et qui respecte vos contraintes, le tout sur l'année complète.

le fichier
Pièce jointe 582297

Le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
    Dim i As Long, j As Long, k As Long
    Dim Lig As Long, C1 As Long, C2 As Long, C3 As Long
    Dim DerLig As Long
    Dim A1 As Long, A2 As Long, A3 As Long, A4 As Long, A5 As Long, A6 As Long, A7 As Long
    Dim Cpt As Double
    Dim Deb As Double
 
Sub Combinaisons_et_TirageAleatoire()
    Deb = Timer
    Application.ScreenUpdating = False
    C1 = 15
    C2 = 16
    C3 = 17
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    For n = 1 To 2
        Range("B2:I" & DerLig).ClearContents
        Lig = 2
 
        'Combinaisons
        For i = 2 To 7
            For j = 2 To 7
                For k = 2 To 7
                    If Cells(i, C1) <> 1 And Cells(j, C2) <> 1 And Cells(k, C3) <> 6 And Cells(i, C1) <> Cells(j, C2) Then
                        Range(Cells(Lig, "E"), Cells(Lig, "G")) = Array(Cells(i, C1), Cells(j, C2), Cells(k, C3))
                        Lig = Lig + 1
                    End If
                Next k
            Next j
        Next i
    Next n
 
Construction:
    'Construction par semaine
    Construction_Par_Semaine
 
    'Remplacement des N° par les affectations
    For i = 1 To 7
        Affect = Cells(i + 10, "T")
        Range("B2:D319").Replace What:=i, Replacement:=Affect, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Next i
    Range("E2:G181, O11:Q16, U11:U17").ClearContents
    MsgBox "Durée: " & Timer - Deb & " Sec"
End Sub
 
Sub Construction_Par_Semaine()
    Randomize
    For n = 2 To 314 Step 6
        Range("O11:Q18").ClearContents
 
Remplissage: 'de la grille de calcul
        L1 = Int((181 * Rnd) + 1) + 1
        Range("O11:Q11").Value = Range("E" & L1 & ":G" & L1).Value
        For i = 12 To 16
            Cpt = 0
ChangerLigne:
            L2 = Int((180 * Rnd) + 1) + 1
            Range("O" & i & ":Q" & i).Value = Range("E" & L2 & ":G" & L2).Value
            A1 = Application.CountIf(Range("O11:Q16"), 1)
            A2 = Application.CountIf(Range("O11:Q16"), 2)
            A3 = Application.CountIf(Range("O11:Q16"), 3)
            A4 = Application.CountIf(Range("O11:Q16"), 4)
            A5 = Application.CountIf(Range("O11:Q16"), 5)
            A6 = Application.CountIf(Range("O11:Q16"), 6)
            A7 = Application.CountIf(Range("O11:Q16"), 7)
            If Cells(i, "O") = Cells(i - 1, "O") Or Cells(i, "P") = Cells(i - 1, "P") Or _
                Cells(i, "O") = Cells(i - 1, "P") Or Cells(i, "P") = Cells(i - 1, "O") Or Cells(i, "Q") = Cells(i - 1, "Q") Then
                Cpt = Cpt + 1
                If Cpt = 20 Then
                    Range("O11:Q18").ClearContents
                    GoTo Remplissage 'Pas de solution trouvée, on recommence tout
                End If
                GoTo ChangerLigne
            End If
            If Application.Max(A1, A2, A3, A4, A5, A6, A7) > 3 Then GoTo ChangerLigne
            If i = 16 And Application.Min(A1, A2, A3, A4, A5, A6, A7) = 0 Then
                Range("O11:Q18").ClearContents
                GoTo Remplissage
            End If
        Next i
 
        'Remplissage du calendrier
        Range("B" & n & ":D" & n + 5).Value = Range("O11:Q16").Value
    Next n
End Sub

Cdlt

**Monda** · 17/08/2022, 08h51

Bonjour Arturo,
Je reprends ma demande en message privé ici car apriori je peux t'envoyer le fichier Excel.
Merci de me dire si tout va bien ou si je dois donner plus d'explication qui sont dans ta boite privée.
Désolé Merci
Sylvain

Envoyé par Monda

Bonjour à vous tous,

Je me débrouille sur Excel au travers de tutos et d’exercices, mais voilà je sèche là, malgré mes recherches.
Je souhaite créé un planning aléatoire sur une année, avec des binômes, avec le moins de redondance possible et avec une exception.

Je m’explique :
Chaque équipe est composée des mêmes personnes
Toutes les personnes en HS peuvent-être en Astreinte sauf la 1 : BS en rouge
Toutes les personnes peuvent-être en Astreinte en même temps qu’en Heures Suppe sauf la 6 : BA.

Les Heures Supp sont en Binôme, 2 personnes à chaque fois.
Seul 1 : BS, ne fait pas d’Heures Supp, mais fait des astreintes

Les Astreinte sont seules, 1 personne à chaque fois.
Seul 6 : BA, ne fait pas d’Astreinte, mais fait des Heures Supp.

1fois / semaine le tout en même temps sur 52 semaines, en répartissant les charges à parts égales le mieux possible

Equipe de base :

Equipe HS	Equipe Binôme HS	Equipe Astreinte
1 : BS	1 : BS	1 : BS
2 : GC	2 : GC	2 : GC
3 : ZA	3 : ZA	3 : ZA
4 : MS	4 : MS	4 : MS
5 : JL	5 : JL	5 : JL
6 : BA	6 : BA	6 : BA
7 : BL	7 : BL	7 : BL

Exemple recherché :
Semaine 1 :

Equipe HS :	Equipe Binôme HS :	Equipe Astreinte :
4 : MS	5 : JL	5 : JL
6 : BA	3 : ZA	3 : ZA
7 : BL	2 : GC	2 : GC
3 : ZA	4 : MS	4 : MS
6 : BA	7 : BL	7 : BL
2 : GC	5 : JL	1 : BS

Semaine 2:

Equipe HS :	Equipe Binôme HS :	Equipe Astreinte :
4 : MS	3 : ZA	3 : ZA
6 : BA	2 : GC	2 : GC
7 : BL	4 : MS	4 : MS
3 : ZA	6 : BA	1 : BS
2 : GC	5 : JL	5 : JL
5 : JL	7 : BL	7 : BL

Déjà comme ça avec 2 semaines je louche, auriez-vous une solution?

Merci de m’avoir lu, en espérant avoir une réponse favorable .
Belle soirée à vous tous
Sylvain

Répartition d'équipe hebdomadaire annuelle et aléatoire

Conception

Vue hybride

Discussions similaires

Partager

Partager