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