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) = Format(t(j, 2), "0." & String(15, "0")) & "z" '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) = Format(t(j, 3), "0." & String(15, "0")) '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 Right(Heures(i), 1) = "z" 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 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
Sub tri(a, b, c, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While a(g) < ref: g = g + 1: Loop
Do While ref < a(d): d = d - 1: Loop
If g <= d Then
temp = a(g): a(g) = a(d): a(d) = temp
temp = b(g): b(g) = b(d): b(d) = temp
temp = c(g): c(g) = c(d): c(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call tri(a, b, c, g, droi)
If gauc < d Then Call tri(a, b, c, gauc, d)
End Sub