VBA-attribuer des places selon horaire

[neeser]

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!

 

[job75]

Bonsoir à tous,

Pour le fun dans le fichier joint j'ai créé des heures totalement aléatoires en utilisant la fonction ALEA().

J'ai vérifié : les heures ont au maximum 19 décimales.

Il faut 8594 bureaux pour placer les 17000 agents.

A+

 

[job75]

Bonsoir neeser, le forum,

Finalement il est bien suffisant - et plus rapide - d'arrondir avec la fonction Round les heures à la 6ème décimale (1/10ème de seconde) :

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) = Round(t(j, 2), 6) + i / "1E13" '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) = Round(t(j, 3), 6) '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 Lig(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

Voyez ce fichier (5) et le fichier permettant de créer des heures aléatoires.

A+