VBA-attribuer des places selon horaire

neeser · 12 Novembre 2016

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!

neeser · 16 Novembre 2016

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.

JBARBE · 16 Novembre 2016

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 !

Malik · 16 Novembre 2016

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

mapomme · 16 Novembre 2016

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

neeser · 16 Novembre 2016

En effet JBARBE, bien vu ça devrait être Éric plutôt que Thomas!

job75 · 16 Novembre 2016

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+

Si... · 16 Novembre 2016

Re Salut

Une autre façon de voir les choses (planning)...

Ne pas hésiter à consulter l'aide (clic sur ?) même si elle est succincte

job75 · 16 Novembre 2016

Re,

J'ai créé 17000 noms sans doublon en colonne A et recopié à l'identique B2:C18 sur B2:C17001.

Avec 10000 bureaux (tout le monde est placé) ma macro s'exécute chez moi en 10 secondes.

A+

neeser · 16 Novembre 2016

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.

job75 · 16 Novembre 2016

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.

job75 · 17 Novembre 2016

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+

job75 · 17 Novembre 2016

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+

neeser · 18 Novembre 2016

Wow, impressionnant, y me reste beaucoup de croutes à manger avant d'en être là dans VBA

ROGER2327 · 18 Novembre 2016

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

job75 · 18 Novembre 2016

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+

VBA-attribuer des places selon horaire

XLDnaute Nouveau

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency