extraire de cellule x à cellule y

Sub test()
Dim DerLig As Long, T, i As Long, S As String

DerLig = Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To DerLig
  S = S & Sheets("Feuil1").Range("A" & i) & " "
Next i

T = Split(Left(S, Len(S) - 1), "bien")

For i = 1 To UBound(T)
  Range("B" & i) = Split(T(i), "ce")(0)
Next i
End Sub

Sub toto()
Dim k&, l&, c&, x(), y$()
Const d$ = "bien"
Const f$ = "ce"
  With Feuil1.[A1]: x = Range(.Cells, .Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Offset(1)).Value: End With
  With Feuil2.[A1]
    With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
    .CurrentRegion.ClearContents
    x(UBound(x), 1) = f
    For k = 1 To UBound(x) - 1
      If LCase(x(k, 1)) = d Then
        c = 0
        Do Until LCase(x(k + 1, 1)) = f Or LCase(x(k + 1, 1)) = d
          k = k + 1
          If Not IsEmpty(x(k, 1)) Then
            ReDim Preserve y(0, c)
            y(0, c) = x(k, 1)
            c = c + 1
          End If
        Loop
        If c Then .Offset(l).Resize(1, c).Value = y
        l = l + 1
      End If
    Next
    With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
  End With
End Sub

=REPT(A2;(MAX((A$1:A1="bien")*LIGNE(A$1:A1))>MAX((A$1:A1="ce")*LIGNE(A$1:A1)))*(A2<>"ce"))

Sub GO()
[B:B].ClearContents
With [A1].CurrentRegion.Offset(, 1)
  .Cells(1) = "Liste"
  If .Rows.Count = 1 Then Exit Sub
  .Cells(2).FormulaArray = "=REPT(A2,(MAX((A$1:A1=""bien"")*ROW(A$1:A1))>MAX((A$1:A1=""ce"")*ROW(A$1:A1)))*(A2<>""ce""))"
  .Cells(2).AutoFill .Offset(1).Resize(.Rows.Count - 1)
  .Value = .Value 'supprime les formules
  .Sort .Cells, xlAscending, Header:=xlYes 'tri
End With
End Sub