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

**ARTURO83** · 27/10/2020, 08h25

Petite amélioration du dernier fichier, pour le confort de votre analyse des répartitions des tâches, j'ai ajouté une synthèse par semaine du nombre de fois ou est employé chaque personne en Heure Sup. ou en Astreinte.
le fichier
Pièce jointe 582302

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
85
86
87
88
89
90
91
92
93
    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:M" & 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:G319").ClearContents
 
    'Bilans hebdomadaires
    For s = 2 To 314 Step 6
        Range("F" & s & ":F" & s + 1).Value = Application.Transpose(Array("HS", "AST"))
        Range("G" & s & ":M" & s + 1).FormulaR1C1 = "=COUNTIF(R" & s & "C1:R" & s + 5 & "C4,R1C)"
        Range("F" & s & ":M" & s + 1).Borders().Weight = xlThin
    Next s
 
    Range("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** · 28/10/2020, 14h03

Bonjour Arturo,
Merci beaucoup votre fichier est fantastique, et surtout la synthèse.
Une dernière chose si vous pouvez, (faudra vraiment que vous me donniez une adresse mail j'aimerais vous remercier pour tout ceci quand même).
Serait-il possible d'équilibrer les HS supp et astreintes, car BA fait trop dheures par rapport aux autres et BS trop d'astreintes…

Après promis je vous embête plus.
Un grand MERCI en tout cas
Sylvain

**ARTURO83** · 29/10/2020, 06h20

Bonjour,

On est bien loin de la demande initiale ou il s'agissait d'une "Répartition d'équipe hebdomadaire annuelle et aléatoire". Il ne reste plus grand chose d'aléatoire dans tout ça.

Pour obtenir une meilleure répartition entre les équipes et sur l'année complète, il faut que je m'y prenne autrement, car comme je l'ai dit au-dessus, il n'y a plus rien d'aléatoire là dedans, disons que c'est de l'aléatoire forcé ou maîrtrisé

En reprenant le précédent fichier, je me suis aperçu que j'ai fait une erreur dans les formules de comptage des Hs et Ast hebdomadaires.

Je vous retourne le même fichier corrigé, avec en plus:
-la possibilité de choisir le nombre d'astreinte autorisée par semaine et par personne (de 1 à 3). Avec le choix 1, la durée d'exécution peut atteindre les 10 secondes contre 1 à 2 secondes pour les 2 autres choix.
-un tableau qui restitue les écarts max et min pour les Heures sup. et Ast ainsi que pour le total. les équipes 1:BS et 6:BA n'entrent pas dans le calcul de ces écarts.
-une mise en forme conditionnelle fait ressortir les valeurs max(en rouge) et min(en vert) pour les hS et Ast et Total des 2 (toujours hors 1:BS et 6:BA)

Pour les dernières modifications demandées, je vais voir comment m'y prendre, cela va me demander un peu de temps, donc patientez.

En attendant, revoici le fichier corrigé
Pièce jointe 582514

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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
Option Explicit
Dim i As Long, j As Long, k As Long, n As Long, s As Long, NbAst As Long
Dim Lig As Long, C1 As Long, C2 As Long, C3 As Long, L1 As Long, L2 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 B1 As Long, B2 As Long, B3 As Long, B4 As Long, B5 As Long, B6 As Long, B7 As Long
Dim Cpt As Double
Dim Deb As Double
Dim Affect As String
 
Sub Combinaisons_et_TirageAleatoire()
    Deb = Timer
    Application.ScreenUpdating = False
    C1 = 15
    C2 = 16
    C3 = 17
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    Range("B2:M" & 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
 
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:G319").ClearContents
 
    'Bilans hebdomadaires
    For s = 2 To 314 Step 6
        Range("F" & s & ":F" & s + 1).Value = Application.Transpose(Array("HS", "AST"))
        Range("G" & s & ":M" & s).FormulaR1C1 = "=COUNTIF(R" & s & "C2:R" & s + 5 & "C3,R1C)"
        Range("G" & s + 1 & ":M" & s + 1).FormulaR1C1 = "=COUNTIF(R" & s & "C4:R" & s + 5 & "C4,R1C)"
        Range("F" & s & ":M" & s + 1).Borders().Weight = xlThin
    Next s
 
    Range("O11:Q16, U11:U17").ClearContents
    MsgBox "Durée: " & Timer - Deb & " Sec"
End Sub
 
Sub Construction_Par_Semaine()
    NbAst = Range("X4").Value
    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)
 
            B1 = Application.CountIf(Range("Q11:Q16"), 1)
            B2 = Application.CountIf(Range("Q11:Q16"), 2)
            B3 = Application.CountIf(Range("Q11:Q16"), 3)
            B4 = Application.CountIf(Range("Q11:Q16"), 4)
            B5 = Application.CountIf(Range("Q11:Q16"), 5)
            B6 = Application.CountIf(Range("Q11:Q16"), 6)
            B7 = Application.CountIf(Range("Q11: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") Or _
                i = 16 And Application.Max(B1, B2, B3, B4, B5, B6, B7) > NbAst 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** · 29/10/2020, 09h41

Bonjour Arturo,

MILLE MERCI à Vous, Franchement… et désolé

Et je patienterai sans aucun souci…
Vous vous rendez compte de l'aide que vous m'apportez? Je n'imagine à peine le temps que vous devez passer sur cette problématique.
INCROYABLE, j'en suis juste au forme conditionnelle avec 1 ou 2 tableaux croisés et quelques fonction SI pour compter 1 heure par ci 1 heure par là…

Ce que j'aimerai savoir savoir faire celà, mais je ne suis pas bon en math.
A plus tard alors, et MERCI encore sincèrement
Sylvain

**ARTURO83** · 29/10/2020, 10h17

Bonjour,

En avant première, je vous présente ma future version.
Prévoir un planning annuel ne sert pas à grand chose vu qu'on ne peut pas dire avec certitude quelles équipes seront à disposition au moment voulu.
Alors je vais vous proposer autre chose, ce sera en semi-automatique, ce qui fait que vous aurez toujours la main pour modifier le planning en fonction de la situation.
le principe:
Le remplissage se fera semaine par semaine,
Pour débuter une semaine, c'est vous qui affecterez avec l'aide de listes déroulantes, les équipes de votre choix sur le premier jour de la semaine, puis en fonction de cette sélection, une liste des combinaisons possibles sera créée excluant tous éléments déjà sélectionnés auparavant. En faisant un double-clic sur l'une des propositions de cette liste des combinaisons disponibles, la sélection viendra s'ajouter à la suite de la précédente, on répète cette dernière opération pour les jours suivants. Des compteurs seront disponibles pour surveiller le nombre d'affectation de chaque équipe. Si pour des raisons diverses, une ou des équipes ne seraient pas disponibles, vous aurez toujours la possibilité de modifier directement, toujours avec des listes déroulantes, les éléments déjà sélectionnés.
Une fois la semaine remplie et validée, elle sera recopiée dans le tableau final, puis on refait la même chose pour la semaine suivante.

Voici a quoi cela ressemblera
Pièce jointe 582532

C'est déjà bien avancé, merci de me dire si cela pourrai vous convenir.

Cdlt

**Monda** · 29/10/2020, 11h36

Arturo :

Ou ai-je les yeux, vous allez me Maudir…
Mais je me rends compte que dans votre tableau semaine 2, 3, 4, etc…
On fait bosser tout le monde…

En réalité, par exemple, chaque Mardi Soir, je dois calculer sur 53 semaines 3 personnes de garde le soir avec les contraintes expliquées soient :
BS pas d'Heures Supp
BA pas d'astreintes

Et pour le reste de l'equipe HS + Astreintes.

Au final des 53 semaines les HS et Astreintes entre tous doivent-être plus ou moins équivalente…

Pourquoi j'avais pas vu cela avant?????
C'est votre tableau il m'a ébloui

Je ne sais plus ou me mettre…

Sylvain

PS : Pour les Congés et autres, ne vous embêtez je ferai un débrayage à la main, ce qui m'importe vraiment c'est d'avoir une liste sur 53 semaines comme base de travail
ET MERCI ENCORE…

**ARTURO83** · 29/10/2020, 11h45

En réalité, par exemple, chaque Mardi Soir, je dois calculer sur 53 semaines 3 personnes de garde le soir avec les contraintes expliquées soient :
BS pas d'Heures Supp
BA pas d'astreintes

D'où l'intérêt de la future proposition, puisqu'il sera en semi-automatique, vous pourrez l'adapter et le modifier à votre guise.

**Monda** · 29/10/2020, 12h00

Rebonjour Arturo,

Cela donnerait à peu près ceci, j'ai repris votre dernier tableur, en supprimant les lignes en trop , mais tjrs avec trop d'astreinte pour bS par rapport aux autres et trop d'heures supp pour BA …

Vraiment désolé…

**ARTURO83** · 29/10/2020, 12h15

Là je m'y perds, moi je vous ai fait un planning avec 6 jours par semaines sur 53 semaines (comme les 2 tableaux déposés par vos soins dans la demande initiale), et vous me retournez un planning seulement avec 1 ligne par semaine sur 53 semaines, Qu'en est-il réellement? Comment faites-vous la répartition d'une journée par rapport aux autres de la même semaine?

**Monda** · 29/10/2020, 12h33

Excusez-moi, je me suis carrément planté vous avez raison,

En réalité, je ne sais pas pourquoi j'ai mis 2 semaines…
En réalité chaque ligne de mes tableaux font 12 semaines en tout…

Et c'est ce que je recherche, il faudrait conserver toutes les contraintes mais considérer chaque ligne de mes tableaux comme des semaines…
Quel abruti je fais…

Pfffuiiiiiiii…
Vraiment désolé
Je ne sais pas si le droit mais je vous laisserai bien mon N° de téléphone si vous voulez…
Sylvain

Envoyé par ARTURO83

Là je m'y perds, moi je vous ai fait un planning avec 6 jours par semaines sur 53 semaines (comme les 2 tableaux déposés par vos soins dans la demande initiale), et vous me retournez un planning seulement avec 1 ligne par semaine sur 53 semaines, Qu'en est-il réellement? Comment faites-vous la répartition d'une journée par rapport aux autres de la même semaine?

**ARTURO83** · 29/10/2020, 18h52

Bonsoir,

Plus je relis le sujet et toutes les discussions qui ont suivies, je pense que depuis le début, j'ai mal interprété le problème et à aucun moment vous m'avez dit que je faisais fausse route.
Depuis le début et d'après vos tableaux je pensais que vous vouliez une répartition par jour, or il semblerait que ce soit par semaine. Evidemment si c'est ça, c'est autre chose.
Voici un planning annuel, cela ressemblerait-il à cela?
Pièce jointe 582581

Cdlt

**Monda** · 29/10/2020, 22h48

Bonsoir Arturo,
Non Non tout est entièrement de ma faute j'étais tellement obnubilé par la complexité de ma demande que quand j'ai vu votre tableau réalisé en si peu d temps, c'est moi qui n'ai pas vu les 300 et quelques lignes alors que je n'en cherchais que 53…

Bref c'est exactement cela, dans le nombre des affectations et l'équilibre sur l'année entre tout le monde…
Maintenant que j'ai les idées plus claires, vous serait-il possible avec les mêmes contraintes que BA reste en colonne B.
Et en colonne D quand on trouve sur la même ligne le même binôme, le déplacer en colonne C.,
Ce qui me donnerait une meilleure visibilité.
Voir le changement par rapport à votre tableau en feuille 1 ou j'exoplique les changements que j'ai fais à la main et ceux qui sont OK en automatique.

Ou alors si trop compliqué que que je puisse le faire manuellement, car la liste déroulante est bloquée sur votre tableur……
Sinon tout est OK pour moi, juste ajouter le bouton moulinette, combinaison, SVP…

Et votre email, si possible car j'aimerais bien pouvoir vous remercier si vous voulez bien.
Je me sens tellement mal de vous avoir fait bosser autant…

Merci à Vous encore en tout cas
Sylvain

Monda_Répartition d'équipe hebdomadaire annuelle et aléatoire_3.3 TEST.xlsm

**ARTURO83** · 30/10/2020, 12h37

Bonjour,

Voilà, je pense que cela devrait vous satisfaire
le fichier
Pièce jointe 582633

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
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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
Option Explicit
Dim i As Long, j As Long, k As Long, n As Long, s As Long, NbAst As Long
Dim Lig As Long, C1 As Long, C2 As Long, C3 As Long, L1 As Long, L2 As Long
Dim DerLig As Long, DerLig_Combin 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 B1 As Long, B2 As Long, B3 As Long, B4 As Long, B5 As Long, B6 As Long, B7 As Long
Dim Cpt As Double
Dim Deb As Double
Dim Affect As String
Dim Val_F As Long
Dim Val_Max As Range, Val_Min As Range
Dim Equip_Max As String, Equip_Min As String, Debut As String
Dim x As Object, Plage As Object
Dim Max_a As Long, Max_b As Long, a As Long, b As Long
Dim Recommence As Boolean
 
Sub Combinaisons_et_TirageAleatoire()
    Deb = Timer
    Application.ScreenUpdating = False
    C1 = 15
    C2 = 16
    C3 = 17
 
Init:
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    Range("B2:D" & DerLig).ClearContents
    Range("E2:M300").Clear
    Lig = 2
 
    'Combinaisons
    For i = 2 To 7
        For j = 2 To 6
            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
 
    'Mettre en F tous ceux qui sont en Heures Sup. et Astreintes
    DerLig_Combin = Range("E" & Rows.Count).End(xlUp).Row
    For i = 2 To DerLig_Combin
        If Cells(i, "E") = Cells(i, "G") Then
            Val_F = Cells(i, "F")
            Cells(i, "F") = Cells(i, "E")
            Cells(i, "E") = Val_F
        End If
    Next i
 
    'Suppression des combinaisons en doubles
    For i = 2 To DerLig_Combin
        Cells(i, "H") = Cells(i, "E") & Cells(i, "F") & Cells(i, "G")
    Next i
    Range("E2:H" & DerLig_Combin).Sort [H1], 1
 
    For i = DerLig_Combin - 1 To 2 Step -1
        If Cells(i, "H") = Cells(i + 1, "H") Then Range(Cells(i + 1, "E"), Cells(i + 1, "H")).Delete
    Next i
    DerLig_Combin = Range("E" & Rows.Count).End(xlUp).Row
    Range("H2:H" & DerLig_Combin).ClearContents
 
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:D54").Replace What:=i, Replacement:=Affect, lookat:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Next i
    Range("E2:G" & DerLig_Combin).ClearContents
 
    'tentatives de minimisation des écarts
    For i = 22 To 23
        Cpt = 0
        If i = 22 Then
            Test_Heure_Sup
            If Recommence = True Then GoTo Init 'les tentatives de réduction des écarts ont échouer, on recomme depuis le début
        ElseIf i = 23 Then
            Test_Ast
            If Recommence = True Then GoTo Init 'les tentatives de réduction des écarts ont échouer, on recomme depuis le début
        End If
    Next i
 
    Range("O11:Q63, U11:U17").ClearContents
    MsgBox "Durée: " & Timer - Deb & " Sec"
End Sub
 
Sub Test_Heure_Sup()
Test_HS:
    Recommence = False
    If Cells(21, i) > 1 Then
        Set Val_Max = Range("V12:V17").Find(Application.Max(Range("V12:V17")), LookIn:=xlValues)
        Set Val_Min = Range("V12:V17").Find(Application.Min(Range("V12:V17")), LookIn:=xlValues)
        Equip_Max = Cells(Val_Max.Row, "T")
        Equip_Min = Cells(Val_Min.Row, "T")
        'on recherche l'équipe_max dans le tableau et si les conditions sont réunies, on la remplace par l'équipe_min
        If Equip_Min = "6 : BA" Then
            Set Plage = Range("B2:B54")
        Else
            Set Plage = Range("B2:C54")
        End If
            With Plage
            Set x = .Find(Equip_Max, lookat:=xlWhole)
            If Not x Is Nothing Then
                Debut = x.Address
                Do
                    If Equip_Min <> Cells(x.Row, "C") And Equip_Min <> Cells(x.Row - 1, "B") And _
                        Equip_Min <> Cells(x.Row + 1, "B") And Equip_Min <> Cells(x.Row + 1, "C") And _
                        Equip_Min <> Cells(x.Row - 1, "C") Then
                        Cells(x.Row, "B") = Equip_Min
                        Cpt = Cpt + 1
                        If Cpt > 50 Then
                            Recommence = True
                            Exit Sub
                        End If
                        GoTo Test_HS 'on relance le test
                    Else
                        Cpt = Cpt + 1
                        If Cpt > 50 Then
                            Recommence = True
                            Exit Sub
                        End If
                        Set x = .FindNext(x)
                    End If
                Loop While Not x Is Nothing And x.Address <> Debut
            End If
        End With
    End If
    If Cells(21, i) > 1 Then GoTo Test_HS 'on relance le test
End Sub
 
Sub Test_Ast()
Test_Ast:
    Recommence = False
    If Cells(21, i) > 1 Then
        Set Val_Max = Range("W10:W15,W17").Find(Application.Max(Range("W10:W15,W17")), LookIn:=xlValues)
        Set Val_Min = Range("W10:W15,W17").Find(Application.Min(Range("W10:W15,W17")), LookIn:=xlValues)
        Equip_Max = Cells(Val_Max.Row, "T")
        Equip_Min = Cells(Val_Min.Row, "T")
        'on recherche l'équipe_max dans le tableau et si les conditions sont réunies, on la remplace par l'équipe_min
        With Range("D2:D54")
            Set x = .Find(Equip_Max, lookat:=xlWhole)
            If Not x Is Nothing Then
                Debut = x.Address
                Do
                    If Equip_Min <> Cells(x.Row, "C") And Equip_Min <> Cells(x.Row - 1, "B") And _
                        Equip_Min <> Cells(x.Row + 1, "B") And Equip_Min <> Cells(x.Row + 1, "C") And _
                        Equip_Min <> Cells(x.Row - 1, "C") Then
                        Cells(x.Row, "D") = Equip_Min
                        Cpt = Cpt + 1
                        If Cpt > 50 Then
                            Recommence = True
                            Exit Sub
                        End If
                        GoTo Test_Ast 'on relance le test
                    Else
                        Cpt = Cpt + 1
                        If Cpt > 50 Then
                            Recommence = True
                            Exit Sub
                        End If
                        Set x = .FindNext(x)
                    End If
                Loop While Not x Is Nothing And x.Address <> Debut
            End If
        End With
    End If
    If Cells(21, i) > 1 Then GoTo Test_Ast 'on relance le test
End Sub
 
Sub Construction_Par_Semaine()
    NbAst = Range("X4").Value
    Randomize
    Range("O11:Q63").ClearContents
 
Remplissage: 'de la grille de calcul
     L1 = Int((130 * Rnd) + 1) + 1
     Range("O11:Q11").Value = Range("E" & L1 & ":G" & L1).Value
     For i = 12 To 63
         Cpt = 0
ChangerLigne:
         L2 = Int((130 * Rnd) + 1) + 1
         Range("O" & i & ":Q" & i).Value = Range("E" & L2 & ":G" & L2).Value
 
 
         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
             GoTo ChangerLigne
             Max_b = 0
                 For n = 1 To 53
                     b = Application.CountIf(Range("O11:Q63"), n)
                     If b > Max_b Then Max_b = b
                 Next n
                 If Max_b > NbAst Then
                     Cpt = Cpt + 1
                     If Cpt = 50 Then
                         Range("O11:Q63").ClearContents
                         GoTo Remplissage 'Pas de solution trouvée, on recommence tout
                     End If
                     GoTo ChangerLigne
                 End If
         End If
             Max_a = 0
             For n = 1 To 53
                 a = Application.CountIf(Range("O11:Q63"), n)
                 If a > Max_a Then Max_a = a
             Next n
         If Max_a > (i - 10) + 1 Then GoTo ChangerLigne
         If i = 53 And Max_a = 0 Then
             Range("O11:Q63").ClearContents
             GoTo Remplissage
         End If
    Next i
 
    'Remplissage du planning
    Range("B2:D54").Value = Range("O11:Q63").Value
End Sub

Cdlt

**Monda** · 30/10/2020, 13h03

Bonjour Arturo,

C'est GEANT… et Génial de votre part et surtout votre patience, vous avez dû me haïr…
Je ne sais coment vous remercier pour tout ceci?

En tout cas un GRAND MERCI encore car vous venez souvent à mon secours.
Merci Mille fois
Sylvain

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

Conception

Discussions similaires

Partager

Partager