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!

 

[JHA]

Bonjour à tous,

Un début de solution par formules

JHA

 

[JBARBE]

Bonjour à tous,
Peut-être ceci qui me semble simple mais à défaut de fichier en exemple je fais ce que je peux !
bonne journée !

 

[job75]

Bonjour neeser, JHA, JBARBE,

JHA j'aime bien ta solution, mais comme j'ai vu que le calcul itératif est activé dans ton fichier je m'en sers.

Formule en C2 du fichier joint :

=SI(B2="";"";SI(ESTNUM(C2);C2;MAINTENANT()))

Avec MAINTENANT() il ne peut pas y avoir de doublon d'heure.

Edit : pour qu'on ne touche pas aux formules en colonnes C et D et G1 j'ai protégé la feuille.

J'ai aussi revu la formule de validation de données en colonne B.

A+

 

[JBARBE]

Bonjour neeser, JHA, job75,

Une autre solution permettant avec un bouton supplémentaire de libérer une ou plusieurs places ainsi que de mettre un nom !
Compte tenu de la demande "Je veux leur attribuer à tous une place déterminée en priorisant tout le temps les plus petits numéro de places " peut-être que la disposition ( place en priorité) de mon fichier est la bonne !

bonne journée à tous !

 

[JBARBE]

Re,
Dans le fichier présent les 35 personnes sont attribuées pour chaque Place ( une boite de dialogue demande si l'on peut prolonger au-delà des 35 mais en respectant les 25 Places assises disponibles !)

Le bouton LIBERER PLACE permet de mettre à l'endroit effacer une autre personne avec le bouton GO !

Ne pas oublier de cliquer sur le bouton EFFACER TOUT avant de commencer à faire des réservations !

bonne journée !

 

[job75]

Re,

Voici une solution VBA avec cette macro dans le code de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NbPlaces As Range, P As Range, mem, a() As Boolean, i&, j&
Set NbPlaces = [D1] 'cellule à adapter
Application.EnableEvents = False 'désactive les évènements
On Error Resume Next
If CLng(NbPlaces) < 1 Then NbPlaces = 0
NbPlaces = CLng(NbPlaces)
Set P = Me.UsedRange.Resize(, 3)
'---tri du tableau---
If Not Intersect(Target, P.Columns(1)) Is Nothing And Target.Count = 1 Then mem = Target
P.Sort P(1), xlAscending, Header:=xlYes
P(Application.Match(mem, P.Columns(1), 0), 1).Select
'---suppressions des lignes des noms effacés---
Intersect(P, P.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow).Delete xlUp
'---contrôle du nombre de places---
If NbPlaces < Application.Count(P.Columns(3)) Then MsgBox "Le nombre de places affectées est supérieur à " _
  & NbPlaces & "." & vbLf & "Vous devez effacer des arrivées en colonne B.", 48
'---mémorisation des places attribuées---
ReDim a(1 To NbPlaces)
For i = 2 To P.Rows.Count
  If IsNumeric(CStr(P(i, 3))) And P(i, 2) <> "" Then a(P(i, 3)) = True
Next i
'---attribution des places---
For i = 2 To P.Rows.Count
  If P(i, 2) = "" Then
    If P(i, 3) <> "" Then P(i, 3) = ""
  Else
    If Not IsNumeric(CStr(P(i, 3))) Then
      For j = 1 To UBound(a)
        If a(j) Then Else P(i, 3) = j: a(j) = True: Exit For
      Next j
      If Not IsNumeric(CStr(P(i, 3))) Then P(i, 3) = "n/a" 'pas nécessaire s'il y a une validation des données en colonne B
    End If
  End If
Next i
Application.EnableEvents = True 'réactive les évènements
End Sub

Fichier joint.

Bonne soirée.

 

[job75]

Re,

La macro précédente est très rapide même sur un grand tableau.

Avec 10000 noms et 5000 places à attribuer la validation d'une arrivée s'exécute chez moi en 0,2 seconde (Win 10 - Excel 2013).

Bonne nuit.

 

[JBARBE]

Re,

Possibilité dés la 1ére saisie de mettre un nom ou laisser faire la macro !

PS: Je crains que neeser ai oublié d'allumer son ordi depuis longtemps Job75 !!!
bonne nuit !

 

[job75]

Re,

Possibilité dés la 1ére saisie de mettre un nom ou laisser faire la macro !

Il me paraît nécessaire de dissocier entrée des noms et validation des arrivées car les noms peuvent être donnés bien avant, et on peut vouloir les conserver même si l'on efface toutes les arrivées.

Pour terminer, si l'on veut afficher les heures des arrivées ce n'est pas un problème mais ce n'est pas du tout indispensable.

Edit : j'ai aussi introduit la variable tableau t, c'est beaucoup plus rapide si l'on valide/efface ensemble un grand nombre d'arrivées :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NbPlaces As Range, P As Range, mem, a() As Boolean, t, i&, j&
Set NbPlaces = [E1] 'cellule à adapter
Application.EnableEvents = False 'désactive les évènements
On Error Resume Next
If CLng(NbPlaces) < 1 Then NbPlaces = 0
NbPlaces = CLng(NbPlaces)
Set P = Me.UsedRange.Resize(, 4)
'---tri du tableau---
If Not Intersect(Target, P.Columns(1)) Is Nothing Then
  If Target.Count = 1 Then mem = Target
  P.Sort P(1), xlAscending, Header:=xlYes
  P(Application.Match(mem, P.Columns(1), 0), 1).Select
End If
'---suppressions des lignes des noms effacés---
Intersect(P, P.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow).Delete xlUp
'---contrôle du nombre de places---
If NbPlaces < Application.Count(P.Columns(4)) Then MsgBox "Le nombre de places attribuées est supérieur à " _
  & NbPlaces & "." & vbLf & "Vous devez effacer des arrivées en colonne B.", 48
'---mémorisation des places attribuées---
ReDim a(1 To NbPlaces)
t = P.Columns(2).Resize(, 3) 'matrice, plus rapide
For i = 2 To UBound(t)
  If IsNumeric(CStr(t(i, 3))) And t(i, 1) <> "" Then a(t(i, 3)) = True
Next i
'---attribution/effacement des places---
For i = 2 To UBound(t)
  If t(i, 1) = "" Then
    If t(i, 3) <> "" Then t(i, 2) = "": t(i, 3) = ""
  Else
    If Not IsNumeric(CStr(t(i, 3))) Then
      For j = 1 To UBound(a)
        If a(j) Then Else t(i, 3) = j: a(j) = True: Exit For
      Next j
      t(i, 2) = Now 'heure
      If Not IsNumeric(CStr(t(i, 3))) Then t(i, 3) = "n/a" 'pas nécessaire s'il y a une validation des données en colonne B
    End If
  End If
Next i
[B1].Resize(UBound(t), 3) = t 'restitution
Application.EnableEvents = True 'réactive les évènements
End Sub

Fichier (2).

PS : peu m'importe que neeser ne revienne pas, je ne travaille pas pour une seule personne quand j'interviens et ce qui m'intéresse c'est de résoudre le problème posé.

Encore bonne nuit.

 

[JBARBE]

Re,
Je vois que l'on a la même passion d'Excel quoi qu'il arrive job75 !
Pour terminé : possibilité de choisir un nombre de places supérieur à 25 comme un nombre de personnes supérieur à 35 !

bonne nuit à tous !

 

[job75]

Bonjour à tous,

On aura remarqué que si l'on diminue en cours de route le nombre de places en E1 il peut y avoir un message d'alerte.

Dans ce fichier (3) j'ai complété pour effacer si on le veut les arrivées excédentaires.

Et si l'on veut alors effacer toutes les arrivées (RAZ) il suffit d'effacer E1 :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NbPlaces As Range, P As Range, mem, maxi As Variant, a() As Boolean, t, i&, j&
Set NbPlaces = [E1] 'cellule à adapter
Application.EnableEvents = False 'désactive les évènements
On Error Resume Next
If CLng(NbPlaces) < 1 Then NbPlaces = 0
NbPlaces = CLng(NbPlaces)
Set P = Me.UsedRange.Resize(, 4)
'---tri du tableau---
If Not Intersect(Target, P.Columns(1)) Is Nothing Then
  If Target.Count = 1 Then mem = Target
  P.Sort P(1), xlAscending, Header:=xlYes
  P(Application.Match(mem, P.Columns(1), 0), 1).Select
End If
'---suppressions des lignes des noms effacés---
Intersect(P, P.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow).Delete xlUp
'---contrôle du nombre de places---
If Not Intersect(Target, NbPlaces) Is Nothing Then If NbPlaces < Application.Max(P.Columns(4)) _
  Then If MsgBox("Vous venez de diminuer le nombre de places." & vbLf & _
  "Voulez-vous effacer celles qui dépassent ce nombre ?", 52) = 6 Then maxi = NbPlaces
'---mémorisation des places attribuées---
ReDim a(1 To NbPlaces)
t = P.Columns(2).Resize(, 3) 'matrice, plus rapide
For i = 2 To UBound(t)
  If IsNumeric(CStr(t(i, 3))) And t(i, 1) <> "" Then a(t(i, 3)) = True
Next i
'---attribution/effacement des places---
For i = 2 To UBound(t)
  If maxi <> "" Then If t(i, 3) > maxi Then t(i, 1) = ""
  If t(i, 1) = "" Then
    If t(i, 3) <> "" Then t(i, 2) = "": t(i, 3) = ""
  Else
    If Not IsNumeric(CStr(t(i, 3))) Then
      For j = 1 To UBound(a)
        If a(j) Then Else t(i, 3) = j: a(j) = True: Exit For
      Next j
      t(i, 2) = Now 'heure
      If Not IsNumeric(CStr(t(i, 3))) Then t(i, 3) = "n/a" 'pas nécessaire s'il y a une validation des données en colonne B
    End If
  End If
Next i
[B1].Resize(UBound(t), 3) = t 'restitution
Application.EnableEvents = True 'réactive les évènements
End Sub

A+

 

[mapomme]

Bonsoir neeser,

Y'a pas de raison! Je m'y mets aussi . Un essai avec un Userform.

• pour passer un membre de la liste des invités à la liste des placés, double-cliquer sur le membre invité
• pour passer un membre de la liste des placés à la liste des partis, double-cliquer sur le membre placé
• les données sont sauvegardées au fur et à mesure; la ré-ouverture du userform après une fermeture doit se faire sans perte de données
• la feuille Data comporte des données nécessaires à la macro et à la sauvegarde des données. C'est sur cette feuille qu'on initialise des données pour une nouvelle série de placements.

 

[neeser]

Bonjour tous le monde, merci beaucoup pour toutes vos réponses, désolé de mon silence, j'ai été absent de l'internet pendant quelques jours, je vais regardé toutes vos excellentes suggestions d'ici ce soir!

 

[Si...]

Salut

pratiques-tu le jeu des chaises tournantes ?