Sub Extraction()
Dim Pl As Range, PlCrit As Range, DerLig As Long, Dercol As Integer, Critere As Range
Dim c, PremAdresse, s As Variant, Nb As Long, NbT As Long, i As Long, j As Long, k As Long
Dim T()
With Sheets("Base")
DerLig = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Dercol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
Set Pl = .Range(.Cells(5, 1), .Cells(DerLig, Dercol))
Set Critere = .Range(.Cells(5, 1), .Cells(5, Dercol))
End With
With Critere
Set c = .Find([Coul], LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
PremAdresse = c.Address
Do
k = 1
If c.Offset(1).Value = [Num] Then
Set PlCrit = Sheets("Base").Range(Sheets("Base").Cells(7, c.Column), Sheets("Base").Cells(DerLig, c.Column))
Nb = Application.WorksheetFunction.CountA(PlCrit)
NbT = NbT + Nb
ReDim Preserve T(NbT - 1)
For i = j To UBound(T)
T(i) = PlCrit(k, 1): k = k + 1
Next i
j = NbT
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> PremAdresse
End If
End With
With Sheets("Resultat")
.Range("B2:B10000").ClearContents
If NbT > 0 Then
.Range("B2").Resize(UBound(T) + 1) = Application.Transpose(T)
.Range("B2").Sort Key1:=[B2], Order1:=xlAscending, Header:=xlGuess 'tri
End If
End With
End Sub