Private Sub Worksheet_Activate()
Dim d As Object, tablo, resu(), i&, x$, nn&, n&, j%, total#
Set d = CreateObject("Scripting.Dictionary")
tablo = Sheets("Présence").[A1].CurrentRegion.Resize(, 4) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 6)
For i = 2 To UBound(tablo)
x = tablo(i, 1) & tablo(i, 3)
If d.exists(x) Then
nn = d(x) 'récupère la ligne
If tablo(i, 4) < resu(nn, 4) Then resu(nn, 4) = tablo(i, 4) 'minimum
If tablo(i, 4) > resu(nn, 5) Then resu(nn, 5) = tablo(i, 4) 'maximum
Else
n = n + 1
d(x) = n 'mémorise la ligne
For j = 1 To 4: resu(n, j) = tablo(i, j): Next j
resu(n, 5) = tablo(i, 4)
End If
Next
'---dernière colonne---
For i = 1 To n
total = resu(i, 5) - resu(i, 4)
If Application.Round(total, 6) Then resu(i, 6) = total Else resu(i, 5) = Empty
Next
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination
If n Then .Resize(n, 6) = resu
.Offset(n).Resize(Rows.Count - n - .Row + 1, 6).ClearContents 'RAZ en dessous
End With
Columns.AutoFit 'ajustement largeurs
End Sub