XL 2016 Répartition équitable de binômes

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
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

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
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

Dernière édition:
Vote positif 0 Vote négatif
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
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

Vote positif 0 Vote négatif
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

Vote positif 0 Vote négatif
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

Dernière édition:
Vote positif 0 Vote négatif
Solution
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
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

halecs93
  • Résolu(e)
XL 2016 Planification aléatoire sur les samedis.
2
Réponses
18
Affichages
473
halecs93
halecs93
N
  • Question 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 Question
Autres répartition équitable de lots
Réponses
5
Affichages
3 K
ebshape
E
N
  • Question Question
Repartition des stocks de produits aux ouvriers - Problème d'arrondi
Réponses
2
Affichages
2 K
Nakoulma
N
R
  • Question Question
Répartition de montants en fonction de plafonds
Réponses
11
Affichages
1 K
CISCO
CISCO
C
  • Question Question
Problèmes d'export de données
Réponses
10
Affichages
2 K
job75
job75
G
  • Question Question
Répartition de recettes et pondération - Rémunération possible
Réponses
0
Affichages
7 K
gathoune6
G
J
  • Question Question
Tableau de répartition
Réponses
3
Affichages
1 K
Jamantaz
J
B
  • Question Question
Rationaliser la constitution de mon fichier
Réponses
10
Affichages
1 K
Bernard34
B
Retour