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