VBA-attribuer des places selon horaire

N

neeser

XLDnaute Nouveau
Bonjour à vous,
Je fais à nouveau appel à votre inépuisable connaissance d'excel pour un problème sur lequel je travaille depuis un temps, sans rien trouvé. J'ai 35 personnes, et 25 places assises (numérotées ou nommées par une lettre peu m'importe). Heureusement, elles ne sont pas là toutes en même temps, avec une gestion adéquate des places tout le monde peut s'asseoir. Je veux leur attribuer à tous une place déterminée en priorisant tout le temps les plus petits numéro de places (par exemple dès que la place numéro 1 ou A se libère, je veux l'attribuer à la prochaine personne qui rentre, même s'il reste d'autre place inutilisées) . J'imagine que ce n'est réalisable qu'en VBA, je suis capable de faire un genre de diagramme de Gantt pour voir qui se chevauche et tout mais je ne suis pas capable de leur attribuer une place selon une règle. Si vous pouviez me donner une piste de solution ce serait très apprécié!

Merci beaucoup!
 
Trier par date Trier par votes
N

neeser

XLDnaute Nouveau
Bonjour tous le monde,
Merci encore pour toutes vos réponses, j'apprends tellement en lisant vos solutions. Je me rend compte que j'ai mal formulé mon problème initial. J'ai donc joins un document afin de pallier mon manque de clarté. Je cherches à assigner des places selon un horaire préétablie, pas selon l'ordre réel d'arrivée, comme dans l'exemple ci-joint. Certaine portion de vos solutions peuvent s'appliquer en partie, mais je ne suis pas suffisamment à l'aise avec les matrices comme Job75 semble l'être pour en être sûr.
La solution de JHA (avec l'apport de Job75) s'approche beaucoup mais je n'avais pas mentionné que l'heure de départ et d'arrivée était connue à l'avance. En fait mon but ultime c'est d'avoir une macro ou un template dans lequel je colle l'horaire de tous les agents afin de leur attribuer un bureau automatiquement.
Merci encore énormément et désolé de mon manque de précision. Je vais prendre l'habitude de toujours poster un exemple c'est plus concret.
 

Pièces jointes

  • Assignation automatique places.xlsx
    10.1 KB · Affichages: 41
Vote positif 0 Vote négatif
JBARBE

JBARBE

XLDnaute Barbatruc
Bonjour à tous,
N'y as-t'il pas erreur ( Thomas) dans :
Assigner un bureau à chaque personne afin que dès que le bureau #1 se libère il soit assigné à un autre agent. Exemple: David, Roger et Thomas auraient tous les 3 le bureau #1 d'assigné.

A la place de Thomas il faudrait peut-être Eric !
bonne journée !
 
Vote positif 0 Vote négatif
M

Malik

XLDnaute Nouveau
Bonjour à tous,

Pourriez-vous m'aider ? comment modifier ma macro pour que les cellules vide ne se copie pas:

Sub Macro30

ActiveSheet.Unprotect
Range("B7:G7").Select
Selection.Copy
Range("B6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B7:C7").Select
Application.CutCopyMode = False
Selection.ClearContents
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True
End Sub
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour à tous,

Une erreur de la v1 aboutit à une erreur quand toutes les places sont occupées. Oublié un -1 dans une condition:
If j <= ListBox2.ListCount-1 Then

le fichier corrigé est joint.

Mais l'énoncé a changé depuis...
 

Pièces jointes

  • neeser- placements- v1a.xlsm
    30.7 KB · Affichages: 46
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour à tous,

C'est la 1ère fois que j'utilise la macro de tri Quick sort avec 4 vecteurs :
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NbPlaces As Range, np&, Places$(), t, ub&
Dim Heures#(), AD$(), Noms$(), Lig&(), i&, j&, x$
Set NbPlaces = [F1] 'cellule à adapter
Application.EnableEvents = False 'désactive les évènements
On Error Resume Next 'sécurité
If CLng(NbPlaces) < 1 Then NbPlaces = 0
NbPlaces = CLng(NbPlaces)
np = NbPlaces
ReDim Places(1 To np)
t = [A1].CurrentRegion.Resize(, 4) 'matrice, plus rapide
ub = UBound(t) - 1
'---listes et classement de toutes les heures---
ReDim Heures(1 To 2 * ub)
ReDim AD(1 To 2 * ub) 'repérage arrivée/départ
ReDim Noms(1 To 2 * ub)
ReDim Lig(1 To 2 * ub) 'repérage de la ligne
For i = 1 To ub 'revue des arrivées
  j = i + 1
  Heures(i) = t(j, 2) + 1 / 864000 'ajout 1/10ème de seconde
  AD(i) = "a" 'repère
  Noms(i) = t(j, 1) 'nom
  Lig(i) = j 'repère
Next
For i = 1 To ub 'revue des départs
  j = i + 1
  Heures(i + ub) = t(j, 3)
  Noms(i + ub) = t(j, 1) 'nom
Next
tri Heures, AD, Noms, Lig, 1, 2 * ub
'---attribution des places---
For i = 1 To 2 * ub
  x = Noms(i)
  If AD(i) = "" Then 'départ
    For j = 1 To np
      If Places(j) = x Then Places(j) = "": Exit For
    Next
  Else 'arrivée
    For j = 1 To np
      If Places(j) = "" Then Places(j) = x: t(Lig(i), 4) = j: Exit For
    Next
    If j > np Then t(Lig(i), 4) = "n/p" 'non placé
  End If
Next
'---restitution des places---
[D1].Resize(ub + 1) = Application.Index(t, , 4)
Application.EnableEvents = True 'réactive les évènements
End Sub

Sub tri(a, b, c, x, gauc, droi)  ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      temp = c(g): c(g) = c(d): c(d) = temp
      temp = x(g): x(g) = x(d): x(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, c, x, g, droi)
If gauc < d Then Call tri(a, b, c, x, gauc, d)
End Sub
Fichier joint.

A+
 

Pièces jointes

  • Assignation automatique places(1).xlsm
    27.9 KB · Affichages: 27
Dernière édition:
Vote positif 0 Vote négatif
N

neeser

XLDnaute Nouveau
Rebonjour,
Si..., ta solution, quoique élégante visuellement, causerait beaucoup de promiscuité sur les bureaux, car si 3 personnes commencent à la même heure, ils sont tous attribués au même bureau.
Job 75, ça fonctionne parfaitement, j'ai pas encore réussi à comprendre le comment, mais ça fonctionne vraiment bien. 17000 agents en 10 secondes... wow! (même si au delà de 30 je serais surpris ^^
Merci beaucoup de votre aide, je vais l'intégrer dans mon document original et m'assurer que je suis capable de comprendre la macro assez pour ça.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Au post #21 j'ai amélioré les commentaires et déclaré String ($) le tableau Places.

La durée d'exécution avec 17000 noms passe à 8 secondes.

Notez que la partie "attribution des places" prend 90% du temps de calcul.

Bonne fin de soirée.
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour neeser, le forum,

L'utilisation du Dictionary fait gagner beaucoup de temps pour la libération des places (on évite une boucle) :
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NbPlaces As Range, np&, Places() As Boolean, t, ub&
Dim Heures#(), Ar() As Boolean, Noms$(), Lig&(), i&, j&, d As Object
Set NbPlaces = [F1] 'cellule à adapter
Application.EnableEvents = False 'désactive les évènements
On Error Resume Next 'sécurité
If CLng(NbPlaces) < 1 Then NbPlaces = 0
NbPlaces = CLng(NbPlaces)
np = NbPlaces
ReDim Places(1 To np)
t = [A1].CurrentRegion.Resize(, 4) 'matrice, plus rapide
ub = UBound(t) - 1
'---listes et classement de toutes les heures---
ReDim Heures(1 To 2 * ub)
ReDim Ar(1 To 2 * ub) 'repérage arrivée/départ
ReDim Noms(1 To 2 * ub)
ReDim Lig(1 To 2 * ub) 'repérage de la ligne
For i = 1 To ub 'revue des arrivées
  j = i + 1
  Heures(i) = t(j, 2) + 1 / 1000000 'ajout 1/10ème de seconde
  Ar(i) = True 'repère
  Noms(i) = t(j, 1) 'nom
  Lig(i) = j 'repère
Next
For i = 1 To ub 'revue des départs
  j = i + 1
  Heures(i + ub) = t(j, 3)
  Noms(i + ub) = t(j, 1) 'nom
Next
tri Heures, Ar, Noms, Lig, 1, 2 * ub
'---attribution des places---
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To 2 * ub
  If Ar(i) Then 'arrivée
    For j = 1 To np
      If Not Places(j) Then Places(j) = True: d(Noms(i)) = j: t(Lig(i), 4) = j: Exit For
    Next
    If j > np Then t(Lig(i), 4) = "n/p" 'non placé
  Else 'départ
    Places(d(Noms(i))) = False
  End If
Next
'---restitution des places---
[D1].Resize(ub + 1) = Application.Index(t, , 4)
Application.EnableEvents = True 'réactive les évènements
End Sub
Fichiers (2)

Avec 17000 noms et 10000 places la durée d'exécution chez moi est de 2 secondes.

A+
 

Pièces jointes

  • Assignation automatique places(2).xlsm
    28.1 KB · Affichages: 34
  • Assignation automatique 10000 places(2).xlsm
    444.1 KB · Affichages: 26
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

J'ai encore gagné du temps en diminuant l'impact de la boucle imbriquée j (recherche des places libres) :
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NbPlaces As Range, np&, Places() As Boolean, t, ub&
Dim Heures#(), Ar() As Boolean, Noms$(), Lig&(), i&, j&, d As Object, x&
Set NbPlaces = [F1] 'cellule à adapter
Application.EnableEvents = False 'désactive les évènements
On Error Resume Next 'sécurité
If CLng(NbPlaces) < 1 Then NbPlaces = 0
NbPlaces = CLng(NbPlaces)
np = NbPlaces
ReDim Places(1 To np)
t = [A1].CurrentRegion.Resize(, 4) 'matrice, plus rapide
ub = UBound(t) - 1
'---listes et classement de toutes les heures---
ReDim Heures(1 To 2 * ub)
ReDim Ar(1 To 2 * ub) 'repérage arrivée/départ
ReDim Noms(1 To 2 * ub)
ReDim Lig(1 To 2 * ub) 'repérage de la ligne
For i = 1 To ub 'revue des arrivées
  j = i + 1
  Heures(i) = t(j, 2) + i / "1E12" 'attribution dans l'ordre du tableau si même heure
  Ar(i) = True 'repère
  Noms(i) = t(j, 1) 'nom
  Lig(i) = j 'repère
Next
For i = 1 To ub 'revue des départs
  j = i + 1
  Heures(i + ub) = t(j, 3)
  Noms(i + ub) = t(j, 1) 'nom
Next
tri Heures, Ar, Noms, Lig, 1, 2 * ub
'---attribution des places---
j = 1 '1ère place libre
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To 2 * ub
  If Ar(i) Then 'arrivée
    If j > np Then
      t(Lig(i), 4) = "n/p" 'non placé
    Else
      Places(j) = True: d(Noms(i)) = j: t(Lig(i), 4) = j
      For j = j + 1 To np 'place libre suivante
        If Not Places(j) Then Exit For
      Next
    End If
  Else 'départ
    x = d(Noms(i))
    Places(x) = False
    If x And x < j Then j = x
  End If
Next
'---restitution des places---
[D1].Resize(ub + 1) = Application.Index(t, , 4)
Application.EnableEvents = True 'réactive les évènements
End Sub
Fichiers (3).

Sur le gros fichier la durée d'exécution est maintenant de 0,56 seconde.

Edit : avec Heures(i) = t(j, 2) + i / "1E12" les places sont attribuées dans l'ordre du tableau pour une même heure d'arrivée.

Les résultats sont différents : David Roger et Gontrand se succèdent au bureau # 1.

A+
 

Pièces jointes

  • Assignation automatique places(3).xlsm
    28.9 KB · Affichages: 38
  • Assignation automatique 10000 places(3).xlsm
    445 KB · Affichages: 29
Dernière édition:
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Bonjour à tous.

Un autre essai beaucoup plus lent, mais...​

Bonne journée.

ℝOGER2327
#8405

Lundi 16 As 144 (Saint Cap, captain - fête Suprême Quarte)
28 Brumaire An CCXXV, 1,6162h - coing
2016-W46-5T03:52:44Z
 

Pièces jointes

  • Placement.xlsm
    717.5 KB · Affichages: 40
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour Roger, le forum,

Oui votre macro est très lente, 61 secondes chez moi.

Mais un grand merci pour votre fichier avec des heures pseudo-aléatoires (comportant donc des fractions de seconde).

Du coup j'ai revu ma méthode de classement des heures pour fonctionner quel que soit le nombre de décimales des heures :
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NbPlaces As Range, np&, Places() As Boolean, t, ub&
Dim Heures$(), Noms$(), Lig&(), i&, j&, d As Object, x&
Set NbPlaces = [F1] 'cellule à adapter
Application.EnableEvents = False 'désactive les évènements
On Error Resume Next 'sécurité
If CLng(NbPlaces) < 1 Then NbPlaces = 0
NbPlaces = CLng(NbPlaces)
np = NbPlaces
ReDim Places(1 To np)
t = [A1].CurrentRegion.Resize(, 4) 'matrice, plus rapide
ub = UBound(t) - 1
'---listes et classement de toutes les heures---
ReDim Heures(1 To 2 * ub)
ReDim Noms(1 To 2 * ub)
ReDim Lig(1 To 2 * ub) 'repérage de la ligne
For i = 1 To ub 'revue des arrivées
  j = i + 1
  Heures(i) = Format(t(j, 2), "0." & String(15, "0")) & "z" 'classé toujours après le départ
  Noms(i) = t(j, 1) 'nom
  Lig(i) = j 'repère
Next
For i = 1 To ub 'revue des départs
  j = i + 1
  Heures(i + ub) = Format(t(j, 3), "0." & String(15, "0")) 'classé toujours avant l'arrivée
  Noms(i + ub) = t(j, 1) 'nom
Next
tri Heures, Noms, Lig, 1, 2 * ub
'---attribution des places---
j = 1 '1ère place libre
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To 2 * ub
  If Right(Heures(i), 1) = "z" Then 'arrivée
    If j > np Then
      t(Lig(i), 4) = "n/p" 'non placé
    Else
      Places(j) = True: d(Noms(i)) = j: t(Lig(i), 4) = j
      For j = j To np 'place libre suivante
        If Not Places(j) Then Exit For
      Next
    End If
  Else 'départ
    x = d(Noms(i))
    Places(x) = False
    If x And x < j Then j = x
  End If
Next
'---restitution des places---
[D1].Resize(ub + 1) = Application.Index(t, , 4)
Application.EnableEvents = True 'réactive les évènements
End Sub

Sub tri(a, b, c, gauc, droi)  ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      temp = c(g): c(g) = c(d): c(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, c, g, droi)
If gauc < d Then Call tri(a, b, c, gauc, d)
End Sub
Fichiers (4).

Nous obtenons tous les deux le même résultat : 7817 bureaux pour que 17000 agents soient tous placés.

Durée d'exécution du gros fichier 0,96 seconde, le tri de textes prend en effet plus de temps .

Edit : vos heures Roger ont un maximum de 4 décimales, tous mes fichiers précédents fonctionnent donc.

A+
 

Pièces jointes

  • Assignation automatique places(4).xlsm
    27.2 KB · Affichages: 38
  • Assignation automatique 7817 places(4).xlsm
    625.3 KB · Affichages: 37
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

Gen Rose
  • Résolu(e)
XL 2019 INDEX EQUIV DECALER avec liste de validation
Réponses
7
Affichages
587
Gen Rose
Gen Rose
J
  • Question
Microsoft 365 Excel 2022 Formulaire VBA - Filtre Multi-Critères en Simultané
Réponses
1
Affichages
1 K
cp4
cp4
K
  • Résolu(e)
Microsoft 365 Questions Doublons, triplons selon des conditions(VBA ou formule)
Réponses
5
Affichages
1 K
kondabalo
K
Etevaldo Santos
  • Résolu(e)
XL 2019 Filtre dynamique (VBA) sur des colonnes avec le format número or date
Réponses
6
Affichages
2 K
CJA33
C
D
  • Question
XL pour MAC Retraitement (trop complexe pour moi) d'une base de données
3 4 5
Réponses
74
Affichages
9 K
didcac
D
Xtian_Québec
  • Question
XL 2016 Récupérer des valeurs à partir d'un fichier PDF
Réponses
4
Affichages
2 K
Xtian_Québec
Xtian_Québec
P
  • Question
Attribuer un code couleur à un mot dans une cellule contenant des phrases
Réponses
5
Affichages
2 K
thebenoit59
T
A
  • Question
VBA - Supprimer cellule en fonction d'une textbox
Réponses
4
Affichages
2 K
alexos
A
B
  • Question
Suivi des modifications d'une cellule dans une feuille vers une autres
Réponses
8
Affichages
1 K
bassmart
B
GMmarin
  • Question
Renvoi des noms selon date et code place travail
Réponses
8
Affichages
12 K
GMmarin
GMmarin

Membres actuellement en ligne

14 membres et 96 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 228
Messages
2 086 417
Membres
103 204
dernier inscrit
alaa20dine01