VBA-attribuer des places selon horaire

  • Initiateur de la discussion Initiateur de la discussion neeser
  • Date de début Date de début

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 !

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!
 
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) :
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) = 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+
 

Pièces jointes

Dernière édition:
- 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
Retour