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!

JHA · 12 Novembre 2016

Bonjour à tous,

Un début de solution par formules

JHA

JBARBE · 12 Novembre 2016

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 · 12 Novembre 2016

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 :

Code:

=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 · 12 Novembre 2016

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 · 12 Novembre 2016

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 · 12 Novembre 2016

Re,

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

Code:

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 · 12 Novembre 2016

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 · 12 Novembre 2016

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 · 13 Novembre 2016

Re,

JBARBE à dit:
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 :

Code:

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 · 13 Novembre 2016

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 · 13 Novembre 2016

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 :

Code:

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 · 13 Novembre 2016

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 · 15 Novembre 2016

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... · 16 Novembre 2016

Salut

pratiques-tu le jeu des chaises tournantes 😉?

VBA-attribuer des places selon horaire

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency