XL 2016 Répartition équitable de binômes

halecs93

halecs93

XLDnaute Impliqué
Bonjour,

Je travaille toujours sur un fichier me permettant de répartir le plus équitablement possible des personnes. Le but étant de créer des binômes différents à affecter les samedis.

J'ai, je crois, pas mal avancé, mais je n'arrive pas à finaliser cet aspect "équitable".

Quelqu'un aurait une proposition plus fiable que la mienne ?

Un grand merci.

1722349327458.png
 

Pièces jointes

  • PLANNING DES SAMEDIS - fonctionnel ter XLD.xlsm
    69.3 KB · Affichages: 14
Solution
job75
La macro avec 3 Dictionary :
VB: 
Sub Tirages()
Dim tablo As Range, nNom%, delai%, dferie As Object, c As Range, dinterdit As Object
Dim d As Object, col%, r1%, r2%, txt$, rejet As Boolean, ecart%
Set tablo = [Tableau1] 'tableau structuré
nNom = tablo.Rows.Count
delai = 42 'au moins 42 jours avant de réutiliser un nom
'---jours fériés à éliminer---
Set dferie = CreateObject("Scripting.Dictionary")
For Each c In [feries]
    If Weekday(c) = 7 Then dferie(c.Value) = ""
Next c
'---binômes interdits---
Set dinterdit = CreateObject("Scripting.Dictionary")
For Each c In [Tableau5].Columns(1).Cells
    dinterdit(c & vbLf & c(1, 2)) = ""
    dinterdit(c(1, 2) & vbLf & c) = ""
Next c
Application.ScreenUpdating = False
Randomize
Set d =...
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour halecs93, le forum,

Une solution très simple en conservant le fichier du post #1 :
VB: 
Sub Tirages()
Dim tablo As Range, nNom%, col%, c As Range, nSam%, r1%, r2%, ecart%
Set tablo = [Tableau1] 'tableau structuré
nNom = tablo.Rows.Count
Application.ScreenUpdating = False
Randomize
'---RAZ---
1 For col = 3 To 25 Step 2
    Sheets("CALENDRIER").Range("A5:A35").Columns(col) = ""
Next col
'---tirages aléatoires---
For col = 2 To 24 Step 2
    For Each c In Sheets("CALENDRIER").Range("A5:A35").Columns(col).Cells
        If IsDate(c) Then
            If Weekday(c) = 7 Then
                nSam = nSam + 1
                Do
                    r1 = 1 + Int(Rnd * nNom)
                    r2 = 1 + Int(Rnd * nNom)
                    c(1, 2) = tablo(r1, 1) & vbLf & tablo(r2, 1)
                    ecart = Application.Max(tablo) - Application.Min(tablo)
                Loop While r1 = r2 Or ecart > 1
            End If
        End If
Next c, col
'---écart nul---
If nSam Mod nNom = 0 And ecart Then GoTo 1
End Sub
A+
 

Pièces jointes

  • PLANNING DES SAMEDIS - fonctionnel ter XLD.xlsm
    44.4 KB · Affichages: 4
Dernière édition:
Vote positif 0 Vote négatif
halecs93

halecs93

XLDnaute Impliqué
job75 à dit:
Bonjour halecs93, le forum,

Une solution très simple en conservant le fichier du post #1 :
VB: 
Sub Tirages()
Dim tablo As Range, nNom%, col%, c As Range, nSam%, r1%, r2%, ecart%
Set tablo = [Tableau1] 'tableau structuré
nNom = tablo.Rows.Count
Application.ScreenUpdating = False
Randomize
'---RAZ---
1 For col = 3 To 25 Step 2
    Sheets("CALENDRIER").Range("A5:A35").Columns(col) = ""
Next col
'---tirages aléatoires---
For col = 2 To 24 Step 2
    For Each c In Sheets("CALENDRIER").Range("A5:A35").Columns(col).Cells
        If IsDate(c) Then
            If Weekday(c) = 7 Then
                nSam = nSam + 1
                Do
                    r1 = 1 + Int(Rnd * nNom)
                    r2 = 1 + Int(Rnd * nNom)
                    c(1, 2) = tablo(r1, 1) & vbLf & tablo(r2, 1)
                    ecart = Application.Max(tablo) - Application.Min(tablo)
                Loop While r1 = r2 Or ecart > 1
            End If
        End If
Next c, col
'---écart nul---
If nSam Mod nNom = 0 And ecart Then GoTo 1
End Sub
A+
Cliquez pour agrandir...
Yes, merci. Mais le souci, c'est que je ne veux pas qu'un nom réapparaisse avant au moins 6 samedis ;)
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour halecs93, le forum,
halecs93 à dit:
Yes, merci. Mais le souci, c'est que je ne veux pas qu'un nom réapparaisse avant au moins 6 samedis ;)
Cliquez pour agrandir...
Avec un Dictionary mémorisant les dates limites il n'y a plus de souci :
VB: 
Sub Tirages()
Dim tablo As Range, nNom%, delai%, d As Object, col%, c As Range, nSam%, r1%, r2, rejet As Boolean, ecart%
Set tablo = [Tableau1] 'tableau structuré
nNom = tablo.Rows.Count
delai = 42 'au moins 42 jours avant de réutiliser un nom
Application.ScreenUpdating = False
Randomize
1 Set d = CreateObject("Scripting.Dictionary")
With Sheets("CALENDRIER").Range("A5:Y35")
    '---RAZ---
    For col = 3 To 25 Step 2
        .Columns(col) = ""
    Next col
    '---tirages aléatoires---
    For col = 2 To 24 Step 2
        For Each c In .Columns(col).Cells
            If IsDate(c) Then
                If Weekday(c) = 7 Then
                    nSam = nSam + 1
                    Do
                        r1 = 1 + Int(Rnd * nNom)
                        r2 = 1 + Int(Rnd * nNom)
                        rejet = r1 = r2 Or c < d(r1) Or c < d(r2) 'cette variable fait gagner du temps
                        If Not rejet Then
                            c(1, 2) = tablo(r1, 1) & vbLf & tablo(r2, 1)
                            ecart = Application.Max(tablo) - Application.Min(tablo)
                        End If
                    Loop While rejet Or ecart > 1
                    d(r1) = c + delai 'mémorise la dernière date limite du 1er nom
                    d(r2) = c + delai 'mémorise la dernière date limite du 2ème nom
                End If
            End If
    Next c, col
End With
'---écart nul---
If nSam Mod nNom = 0 And ecart Then GoTo 1 'si nécessaire...
End Sub
Je pense que vous comprendrez pourquoi la variable rejet fait gagner du temps.

A+
 

Pièces jointes

  • PLANNING DES SAMEDIS - fonctionnel ter XLD.xlsm
    45.5 KB · Affichages: 2
Vote positif 0 Vote négatif
halecs93

halecs93

XLDnaute Impliqué
job75 à dit:
Bonjour halecs93, le forum,

Avec un Dictionary mémorisant les dates limites il n'y a plus de souci :
VB: 
Sub Tirages()
Dim tablo As Range, nNom%, delai%, d As Object, col%, c As Range, nSam%, r1%, r2, rejet As Boolean, ecart%
Set tablo = [Tableau1] 'tableau structuré
nNom = tablo.Rows.Count
delai = 42 'au moins 42 jours avant de réutiliser un nom
Application.ScreenUpdating = False
Randomize
1 Set d = CreateObject("Scripting.Dictionary")
With Sheets("CALENDRIER").Range("A5:Y35")
    '---RAZ---
    For col = 3 To 25 Step 2
        .Columns(col) = ""
    Next col
    '---tirages aléatoires---
    For col = 2 To 24 Step 2
        For Each c In .Columns(col).Cells
            If IsDate(c) Then
                If Weekday(c) = 7 Then
                    nSam = nSam + 1
                    Do
                        r1 = 1 + Int(Rnd * nNom)
                        r2 = 1 + Int(Rnd * nNom)
                        rejet = r1 = r2 Or c < d(r1) Or c < d(r2) 'cette variable fait gagner du temps
                        If Not rejet Then
                            c(1, 2) = tablo(r1, 1) & vbLf & tablo(r2, 1)
                            ecart = Application.Max(tablo) - Application.Min(tablo)
                        End If
                    Loop While rejet Or ecart > 1
                    d(r1) = c + delai 'mémorise la dernière date limite du 1er nom
                    d(r2) = c + delai 'mémorise la dernière date limite du 2ème nom
                End If
            End If
    Next c, col
End With
'---écart nul---
If nSam Mod nNom = 0 And ecart Then GoTo 1 'si nécessaire...
End Sub
Je pense que vous comprendrez pourquoi la variable rejet fait gagner du temps.

A+
Cliquez pour agrandir...
Bonjour et merci.

Très efficace, en effet.

J'ai "bricolé" deux codes afin d'ajouter deux contraintes supplémentaires, à savoir :

- Interdire de facto certains binômes ;
- Ne pas générer de binômes si un samedi est férié.

Je pense que ça fonctionne :)

Et puis, une feuille "resume".

Je mets le fichier ici.

Encore merci à tous.
 

Pièces jointes

  • PLANNING DES SAMEDIS xld.xlsm
    54.8 KB · Affichages: 2
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
La macro avec 3 Dictionary :
VB: 
Sub Tirages()
Dim tablo As Range, nNom%, delai%, dferie As Object, c As Range, dinterdit As Object
Dim d As Object, col%, r1%, r2%, txt$, rejet As Boolean, ecart%
Set tablo = [Tableau1] 'tableau structuré
nNom = tablo.Rows.Count
delai = 42 'au moins 42 jours avant de réutiliser un nom
'---jours fériés à éliminer---
Set dferie = CreateObject("Scripting.Dictionary")
For Each c In [feries]
    If Weekday(c) = 7 Then dferie(c.Value) = ""
Next c
'---binômes interdits---
Set dinterdit = CreateObject("Scripting.Dictionary")
For Each c In [Tableau5].Columns(1).Cells
    dinterdit(c & vbLf & c(1, 2)) = ""
    dinterdit(c(1, 2) & vbLf & c) = ""
Next c
Application.ScreenUpdating = False
Randomize
Set d = CreateObject("Scripting.Dictionary")
With Sheets("CALENDRIER").Range("A5:Y35")
    '---RAZ---
    For col = 3 To 25 Step 2
        .Columns(col) = ""
    Next col
    '---tirages aléatoires---
    For col = 2 To 24 Step 2
        For Each c In .Columns(col).Cells
            If IsDate(c) Then
                If Weekday(c) = 7 Then
                    If Not dferie.exists(c.Value) Then
                        Do
                            r1 = 1 + Int(Rnd * nNom)
                            r2 = 1 + Int(Rnd * nNom)
                            txt = tablo(r1, 1) & vbLf & tablo(r2, 1)
                            rejet = r1 = r2 Or dinterdit.exists(txt) Or c < d(r1) Or c < d(r2) 'cette variable fait gagner du temps
                            If Not rejet Then
                                c(1, 2) = txt
                                ecart = Application.Max(tablo) - Application.Min(tablo)
                            End If
                        Loop While rejet Or ecart > 1
                        d(r1) = c + delai 'mémorise la dernière date limite du 1er nom
                        d(r2) = c + delai 'mémorise la dernière date limite du 2ème nom
                    End If
                End If
            End If
    Next c, col
End With
End Sub
 

Pièces jointes

  • PLANNING DES SAMEDIS xld.xlsm
    42.1 KB · Affichages: 8
Dernière édition:
Vote positif 0 Vote négatif
Solution
halecs93

halecs93

XLDnaute Impliqué
job75 à dit:
La macro avec 3 Dictionary :
VB: 
Sub Tirages()
Dim tablo As Range, nNom%, delai%, dferie As Object, c As Range, dinterdit As Object
Dim d As Object, col%, nSam%, r1%, r2%, txt$, rejet As Boolean, ecart%
Set tablo = [Tableau1] 'tableau structuré
nNom = tablo.Rows.Count
delai = 42 'au moins 42 jours avant de réutiliser un nom
'---jours fériés à éliminer---
Set dferie = CreateObject("Scripting.Dictionary")
For Each c In [feries]
    If Weekday(c) = 7 Then dferie(c.Value) = ""
Next c
'---binômes interdits---
Set dinterdit = CreateObject("Scripting.Dictionary")
For Each c In [Tableau5].Columns(1).Cells
    dinterdit(c & vbLf & c(1, 2)) = ""
    dinterdit(c(1, 2) & vbLf & c) = ""
Next c
Application.ScreenUpdating = False
Randomize
1 Set d = CreateObject("Scripting.Dictionary")
With Sheets("CALENDRIER").Range("A5:Y35")
    '---RAZ---
    For col = 3 To 25 Step 2
        .Columns(col) = ""
    Next col
    '---tirages aléatoires---
    For col = 2 To 24 Step 2
        For Each c In .Columns(col).Cells
            If IsDate(c) Then
                If Weekday(c) = 7 Then
                    If Not dferie.exists(c.Value) Then
                        nSam = nSam + 1
                        Do
                            r1 = 1 + Int(Rnd * nNom)
                            r2 = 1 + Int(Rnd * nNom)
                            txt = tablo(r1, 1) & vbLf & tablo(r2, 1)
                            rejet = r1 = r2 Or dinterdit.exists(txt) Or c < d(r1) Or c < d(r2) 'cette variable fait gagner du temps
                            If Not rejet Then
                                c(1, 2) = txt
                                ecart = Application.Max(tablo) - Application.Min(tablo)
                            End If
                        Loop While rejet Or ecart > 1
                        d(r1) = c + delai 'mémorise la dernière date limite du 1er nom
                        d(r2) = c + delai 'mémorise la dernière date limite du 2ème nom
                    End If
                End If
            End If
    Next c, col
End With
'---écart nul---
If nSam Mod nNom = 0 And ecart Then GoTo 1 'si nécessaire...
End Sub
Cliquez pour agrandir...
Merci...je regarderai cela de plus près demain
 
Vote positif 0 Vote négatif

Discussions similaires

halecs93
  • Résolu(e)
XL 2016 Planification aléatoire sur les samedis.
2
Réponses
18
Affichages
324
halecs93
halecs93
N
  • Question
XL 2016 J’ai un problème de foies gras de canards
2 3
Réponses
38
Affichages
3 K
TooFatBoy
TooFatBoy
E
  • Question
Autres répartition équitable de lots
Réponses
5
Affichages
3 K
ebshape
E
G
  • Question
Répartir des places de manière équitable sur l'année
Réponses
0
Affichages
750
GGG
G
N
  • Question
Repartition des stocks de produits aux ouvriers - Problème d'arrondi
Réponses
2
Affichages
2 K
Nakoulma
N
G
  • Question
Répartition de recettes et pondération - Rémunération possible
Réponses
0
Affichages
7 K
gathoune6
G
J
  • Question
Tableau de répartition
Réponses
3
Affichages
1 K
Jamantaz
J
B
  • Question
Rationaliser la constitution de mon fichier
Réponses
10
Affichages
1 K
Bernard34
B

Membres actuellement en ligne

16 membres et 318 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 422
Messages
2 109 447
Membres
110 482
dernier inscrit
ilyxxxh