[Résolu] rotation équipe aléatoire selon plusieurs listes données

M

munkycool

XLDnaute Junior
Bonjour,

Suite à la réussite de la mis en forme de mon tableau, je reviens vers vous concernant un nouveau problème.

Dans mon fichier ci-joint, la première feuille "Planning Téléphone" j'aimerais gérer ce planning selon les personnes présentes un jour J. Cela a été fait grâce à Job75 qui m'a permis de récupérer une lise de nom différente selon les journées.

Il faudrait maintenant que je fasse un placement aléatoire de ces personnes selon la journée.
En sachant qu'il y'a 1 personnes pour le mail, 3 à 4 personne au téléphone le matin et 3 ou 4 personnes au téléphone l'après midi. Il y'a pour le moment 8 personne au total.

J'ai trouvé pas mal de solution mais pour une seule liste et non pour plusieurs.

Merci par avance pour votre aide :)
 

Pièces jointes

  • Planning Téléphone test (1).xls
    206.5 KB · Affichages: 163
  • Planning Téléphone test (1).xls
    206.5 KB · Affichages: 163
  • Planning Téléphone test (1).xls
    206.5 KB · Affichages: 162
Dernière édition:
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : rotation équipe aléatoire selon plusieurs listes données

Bojour munkycool,

La présentation du fichier ci-joint paraît nettement plus judicieuse.

La macro dans le code de la feuille Planning Téléphone :

Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row <> 21 Or IsEmpty(Target) Then Exit Sub 'ligne à adapter
Dim n%, plage As Range, r!, h1 As Byte, h2 As Byte
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Cancel = True
n = 14 'nombre d'employés, à adapter
Set plage = Target(2).Resize(n)
plage = Cells(4, Target.Column).Resize(n).Value
plage.Insert xlToRight
With plage.Offset(, -1)
  .FormulaR1C1 = "=IF(RC[1]<>"""",RAND())"
  .Resize(, 2).Sort .Columns, xlAscending, Header:=xlNo
  .Delete xlToLeft
End With
Randomize
r = Rnd
h1 = IIf(r < 0.5, 3, 4)
h2 = IIf(r < 0.5, 4, 3)
plage.Interior.ColorIndex = xlNone 'RAZ
plage(1).Interior.Color = [F19].Interior.Color 'F19 à adapter
plage(2).Resize(h1).Interior.Color = [H19].Interior.Color
plage(2 + h1).Resize(h2).Interior.Color = [J19].Interior.Color
Application.Calculation = xlCalculationAutomatic
End Sub

Les lignes 2 à 17 peuvent être masquées.

A+
 

Pièces jointes

  • Planning Téléphone test (1).xls
    178 KB · Affichages: 107
  • Planning Téléphone test (1).xls
    178 KB · Affichages: 121
  • Planning Téléphone test (1).xls
    178 KB · Affichages: 126
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : rotation équipe aléatoire selon plusieurs listes données

Re,

On peut bien sûr traiter d'un seul clic le mois entier :

Code: 
Private Sub Label1_Click()
Dim n%, cel As Range, plage As Range, r!, h1 As Byte, h2 As Byte
n = 14 'nombre d'employés, à adapter
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each cel In [A21:AE21] 'plage à adapter
  Set plage = cel(2).Resize(n)
  plage = Cells(4, cel.Column).Resize(n).Value
  plage.Insert xlToRight
  With plage.Offset(, -1)
    .FormulaR1C1 = "=IF(RC[1]<>"""",RAND())"
    .Resize(, 2).Sort .Columns, xlAscending, Header:=xlNo
    .Delete xlToLeft
  End With
  Randomize
  r = Rnd
  h1 = IIf(r < 0.5, 3, 4)
  h2 = IIf(r < 0.5, 4, 3)
  plage.Interior.ColorIndex = xlNone 'RAZ
  plage(1).Interior.Color = [F19].Interior.Color 'F19 à adapter
  plage(2).Resize(h1).Interior.Color = [H19].Interior.Color
  plage(2 + h1).Resize(h2).Interior.Color = [J19].Interior.Color
Next
Application.Calculation = xlCalculationAutomatic
End Sub
Nouveau fichier joint.

A+
 

Pièces jointes

  • Planning Téléphone test mois entier(1).xls
    185.5 KB · Affichages: 78
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : rotation équipe aléatoire selon plusieurs listes données

Re,

Une petite remarque en passant sur votre fichier.

Dans la feuille Septembre 2012 les week-ends sont colorés par une MFC, et normalement ils n'ont aucune couleur de fond.

Sauf en C13 où la couleur de fond est blanche (code 2) :

Code: 
Sub Couleur()
MsgBox Sheets("Septembre 2012").[C13].Interior.ColorIndex
End Sub
De ce fait le nom j n'apparaît pas le dimanche 2 septembre.

A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : rotation équipe aléatoire selon plusieurs listes données

Bonjour munkycool,

Si l'on veut colorer les week-ends en gris :

Code: 
Private Sub Label1_Click()
Dim n%, plage As Range, cel As Range, r!, h1 As Byte, h2 As Byte
n = 14 'nombre d'employés, à adapter
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set plage = [A21:AE21] 'plage des dates, à adapter
plage.Offset(1).Resize(n).Interior.ColorIndex = xlNone 'RAZ
For Each cel In plage
  Set plage = cel(2).Resize(n)
  If Weekday(cel, 2) > 5 Then
    plage.ClearContents
    plage.Interior.ColorIndex = 15 'gris
  Else
    plage = Cells(4, cel.Column).Resize(n).Value
    plage.Insert xlToRight
    With plage.Offset(, -1)
      .FormulaR1C1 = "=IF(RC[1]<>"""",RAND())"
      .Resize(, 2).Sort .Columns, xlAscending, Header:=xlNo
      .Delete xlToLeft
    End With
    Randomize
    r = Rnd
    h1 = IIf(r < 0.5, 3, 4)
    h2 = IIf(r < 0.5, 4, 3)
    plage(1).Interior.Color = [F19].Interior.Color 'F19 à adapter
    plage(2).Resize(h1).Interior.Color = [H19].Interior.Color
    plage(2 + h1).Resize(h2).Interior.Color = [J19].Interior.Color
  End If
Next
Application.Calculation = xlCalculationAutomatic
End Sub
Fichier (2).

A+
 

Pièces jointes

  • Planning Téléphone test mois entier(2).xls
    190 KB · Affichages: 63
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : rotation équipe aléatoire selon plusieurs listes données

Re,

Noter que des formules de liaison suffisent dans les cellules des lignes 4 à 17. En 'Planning Téléphone'!A4 :

Code: 
=REPT('Septembre 2012'!B22;'Septembre 2012'!B22<>"")
Edit : Le recalcul du classeur est ainsi 2 fois plus rapide.

Ci-joint les 2 fichiers avec les macros adaptées.

A+
 

Pièces jointes

  • Planning Téléphone test mois entier(3).xls
    150 KB · Affichages: 63
  • Planning Téléphone test (2).xls
    136.5 KB · Affichages: 53
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : rotation équipe aléatoire selon plusieurs listes données

Bonjour munkycool, le forum,

Cette version combine le clic sur le Label et le double-clic sur une date.

La macro Tirage est paramétrée :

Code: 
Dim h1 As Byte 'mémorise la variable

Private Sub Label1_Click()
Dim cel As Range
For Each cel In [A21:AE21] 'plage à adapter
  Tirage cel
Next
Application.Calculation = xlCalculationAutomatic
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [A21:AE21]) Is Nothing Then Exit Sub 'plage à adapter
Cancel = True
Tirage Target
Application.Calculation = xlCalculationAutomatic
End Sub

Sub Tirage(cel As Range)
Dim n%, plage As Range, h2 As Byte
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
n = 14 'nombre d'employés, à adapter
Set plage = cel(2).Resize(n)
plage = Cells(4, cel.Column).Resize(n).Value
If Weekday(cel, 2) > 5 Then
  plage.Interior.Color = [L19].Interior.Color 'L19 à adapter
Else
  plage.Insert xlToRight
  With plage.Offset(, -1)
    .FormulaR1C1 = "=IF(RC[1]<>"""",RAND())"
    .Resize(, 2).Sort .Columns, xlAscending, Header:=xlNo
    .Delete xlToLeft
  End With
  h1 = IIf(h1 = 3, 4, 3)
  h2 = IIf(h1 = 3, 4, 3)
  plage.Interior.ColorIndex = xlNone 'RAZ
  plage(1).Interior.Color = [F19].Interior.Color 'F19 à adapter
  plage(2).Resize(h1).Interior.Color = [H19].Interior.Color
  plage(2 + h1).Resize(h2).Interior.Color = [J19].Interior.Color
End If
End Sub
Voir ce fichier (3) et bien noter :

- les nombres 3 et 4 ne sont plus aléatoires mais s'alternent.

- les lignes 2 à 17 et 30 à 35 sont masquées.

A+
 

Pièces jointes

  • Planning Téléphone test (3).xls
    154 KB · Affichages: 56
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : rotation équipe aléatoire selon plusieurs listes données

Re,

Voici avec le fichier joint une solution qui permet de traiter plusieurs mois.

Dans la feuille Planning Téléphone :

- un mois doit toujours être créé avec 2 tableaux (le nombre d'employés peut varier chaque mois)

- le 2ème tableau (formules de liaison) est nommé avec le nom du mois (tiret bas à la place de l'espace)

- une Zone de texte (et pas un Label) est créée et renommée avec le même nom.

Les macros :

Code: 
Dim h1 As Byte 'mémorise la variable

Sub ZoneTexteClic()
Dim lig As Long, tableau As Range, cel As Range
On Error Resume Next 'sécurité
lig = Application.Match(Replace(Application.Caller, "_", " "), [A:A], 0) + 3
Set tableau = Range(Application.Caller)
For Each cel In Intersect(Rows(lig), tableau.EntireColumn)
  Tirage cel, tableau
Next
Application.Calculation = xlCalculationAutomatic
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not IsDate(Target) Then Exit Sub
Dim tableau As Range
Cancel = True
On Error Resume Next 'sécurité
Set tableau = Range(Replace(Cells(Target.Row - 3, 1), " ", "_"))
Tirage Target, tableau
Application.Calculation = xlCalculationAutomatic
End Sub

Sub Tirage(cel As Range, tableau As Range)
Dim plage As Range, h2 As Byte
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set plage = cel(2).Resize(tableau.Columns(1).Cells.Count)
plage = Intersect(tableau, cel.EntireColumn).Value
If Weekday(cel, 2) > 5 Then
  plage.Interior.Color = Cells(cel.Row - 2, "L").Interior.Color
Else
  plage.Insert xlToRight
  With plage.Offset(, -1)
    .FormulaR1C1 = "=IF(RC[1]<>"""",RAND())"
    .Resize(, 2).Sort .Columns, xlAscending, Header:=xlNo
    .Delete xlToLeft
  End With
  h1 = IIf(h1 = 3, 4, 3)
  h2 = IIf(h1 = 3, 4, 3)
  plage.Interior.ColorIndex = xlNone 'RAZ
  plage(1).Interior.Color = Cells(cel.Row - 2, "F").Interior.Color
  plage(2).Resize(h1).Interior.Color = Cells(cel.Row - 2, "H").Interior.Color
  plage(2 + h1).Resize(h2).Interior.Color = Cells(cel.Row - 2, "J").Interior.Color
End If
End Sub
Par ailleurs, il est impératif que les tableaux des feuilles mois aient toujours l'option "présence".

D'où cette macro dans ThisWorkbook :

Code: 
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Dim flag As Boolean
With Sh.[A:AF]
  If Application.CountIf(.Cells, "absences") Then _
    flag = True: .Replace "absences", "présence", xlWhole
  If Application.CountIf(.Cells, "congés") Then _
    flag = True: .Replace "congés", "présence", xlWhole
  If flag Then .Calculate
End With
End Sub
A+
 

Pièces jointes

  • Planning Téléphone plusieurs mois(1).xls
    265 KB · Affichages: 60
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : rotation équipe aléatoire selon plusieurs listes données

Bonsoir munkycool,

Parlons maintenant du temps de calcul.

En mode automatique, les fonctions volatiles sont recalculées à chaque modification du classeur.

Sur mon portable avec Win7/Excel 2010 :

- le fichier (1) du post #9 (2 mois) se recalcule en 0,45 s soit 2,7 s pour 12 mois

- le fichier (2) joint (2 mois) se recalcule en 0,085 s soit 0,51 s pour 12 mois.

Le secret : les formules matricielles appliquées à chaque colonne, par exemple en
'Septembre 2012'!D22: D35 :

Code: 
=TRANSPOSE(LISTE_SI_COULEUR(DECALER($A$4;;EQUIV(D$20;$3:$3;0)-1;14);INDEX($AK:$AK;EQUIV(D$21;$AJ:$AJ;0))))
A+
 

Pièces jointes

  • Planning Téléphone plusieurs mois(2).xls
    229.5 KB · Affichages: 46
Vote positif 0 Vote négatif
M

munkycool

XLDnaute Junior
Re : rotation équipe aléatoire selon plusieurs listes données

Ouah !! Je suis vraiment impressioné Job75 et vous remercie de vos recherches...même le week-end :)

j'ai juste 2 petites questions :

- Est-il possible de conserver une présentation avec en abcisse les labels "Mail", "Tel AM" et "Tel PM" et en ordonnée les jours de la semaine ?

- Est-il possible, également, de cacher ou de supprimer les colonnes Week-end car personne ne travaille pendant ces 2 jours ?

Cdt
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : rotation équipe aléatoire selon plusieurs listes données

Bonjour munkycool, le forum,

1) Il est finalement plus simple de définir les noms SEPTEMBRE_2012, OCTOBRE_2012... dans les feuilles des mois.

Voir fichier (3).

2) On peut supprimer les week-ends, voir le nouveau fichier (1) avec ce code :

Code: 
Dim h1 As Byte 'mémorise la variable

Sub ZoneTexteClic()
Dim lig As Long, tableau As Range, cel As Range, col As Variant
On Error Resume Next 'sécurité
lig = Application.Match(Replace(Application.Caller, "_", " "), [A:A], 0) + 3
Set tableau = Evaluate(ThisWorkbook.Names(Application.Caller).RefersTo)
For Each cel In Cells(lig, 1).Resize(, 31)
  If IsDate(cel) Then
    col = Application.Match(cel, tableau.Offset(-2).Rows(1), 0)
    Tirage cel, tableau.Columns(col)
  End If
Next
Application.Calculation = xlCalculationAutomatic
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not IsDate(Target) Then Exit Sub
Dim tableau As Range, col As Byte
Cancel = True
On Error Resume Next 'sécurité
Set tableau = Evaluate(ThisWorkbook.Names(Replace(Cells(Target.Row - 3, 1), " ", "_")).RefersTo)
col = Application.Match(Target, tableau.Offset(-2).Rows(1), 0)
Tirage Target, tableau.Columns(col)
Application.Calculation = xlCalculationAutomatic
End Sub

Sub Tirage(cel As Range, tableau As Range)
Dim plage As Range, h2 As Byte
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set plage = cel(2).Resize(tableau.Rows.Count)
plage = tableau.Value
plage.Insert xlToRight
With plage.Offset(, -1)
  .FormulaR1C1 = "=IF(RC[1]<>"""",RAND())"
  .Resize(, 2).Sort .Columns, xlAscending, Header:=xlNo
  .Delete xlToLeft
End With
h1 = IIf(h1 = 3, 4, 3)
h2 = IIf(h1 = 3, 4, 3)
plage.Interior.ColorIndex = xlNone 'RAZ
plage(1).Interior.Color = Cells(cel.Row - 2, "F").Interior.Color
plage(2).Resize(h1).Interior.Color = Cells(cel.Row - 2, "H").Interior.Color
plage(2 + h1).Resize(h2).Interior.Color = Cells(cel.Row - 2, "J").Interior.Color
End Sub
Masquer les lignes 13 à 18 et 32 à 37.

3) On peut toujours envisager d'autres présentations mais celle proposée est la plus logique et la plus simple.

A+
 

Pièces jointes

  • Planning Téléphone plusieurs mois(3).xls
    173.5 KB · Affichages: 91
  • Planning Téléphone plusieurs mois sans week-ends(1).xls
    166 KB · Affichages: 56
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

Y
  • Question
XL 2016 Tournoi 12 équipes 2 poules de 6
Réponses
1
Affichages
406
Volvo64400
Volvo64400
D
  • Question
XL 2016 Rotation planning
Réponses
5
Affichages
1 K
fanfan38
fanfan38
Y
  • Question
Autres google sheets ou bien excel
Réponses
2
Affichages
319
yus
Y
S
  • Question
XL 2016 compter une valeur spécifique avec plusieurs critères
Réponses
6
Affichages
357
Cousinhub
Cousinhub
W
  • Question
XL 2019 Planning permanence heure avec roulement équitable
Réponses
2
Affichages
2 K
wals137
W
P
  • Question
XL 2016 Tableau d'affectation aléatoire par roulement sur 2 postes en binôme pour 8 agents
Réponses
5
Affichages
689
p56
p56
D
  • Question
Autres tableau rotation equipe
2
Réponses
15
Affichages
4 K
sylvanu
sylvanu
M
  • Question
XL 2019 Répartition de données qui n'aboutit pas sur la somme initiale
Réponses
6
Affichages
320
MCO2406
M
N
  • Résolu(e)
Microsoft 365 Cumul de deux TCD
Réponses
12
Affichages
886
Nounours4173
N
H
  • Question
XL 2021 [Résolu] Récupérer informations dans plusieurs classeurs et les centraliser dans un autre
2
Réponses
16
Affichages
533
Cousinhub
Cousinhub

Membres actuellement en ligne

26 membres et 191 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
312 271
Messages
2 086 686
Membres
103 370
dernier inscrit
pasval