Private Sub Worksheet_Change(ByVal Target As Range)
Dim filtre As Range, dest As Range, n&, t, a(), b(), f$, i&
Set filtre = [I1] 'à adapter
Set dest = [H3] 'à adapter
If Intersect(Target, filtre) Is Nothing Then Exit Sub
With [A1].CurrentRegion.Resize(, 6)
n = Application.CountIf(.Columns(2), filtre)
If n Then
t = .Value 'tableau VBA, plus rapide
ReDim a(1 To 2 * n): ReDim b(1 To 2 * n) 'tableaux à 1 dimension
f = filtre 'scalaire, plus rapide
n = 0
For i = 2 To UBound(t)
If t(i, 2) = f Then
n = n + 1: a(n) = t(i, 4): b(n) = t(i, 3)
n = n + 1: a(n) = t(i, 6): b(n) = t(i, 5)
End If
Next
tri a, b, 1, n
ReDim t(1 To n, 1 To 2)
For i = 1 To n 'transposition
t(i, 1) = a(i)
t(i, 2) = b(i)
Next
dest(2).Resize(n, 2) = t 'restitution
End If
End With
dest.Offset(n + 1).Resize(Rows.Count - n - dest.Row, 2).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Sub tri(a, b, 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
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub