Sub toto()
Dim k&, l&, c&, x(), y$()
Const d$ = "x"
Const f$ = "y"
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
ReDim y(0, 0)
y(0, 0) = x(k, 1)
c = 1
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
ReDim Preserve y(0, c + 1)
y(0, c) = x(k + 1, 1)
.Offset(l).Resize(1, c + 1).Value = y
l = l + 1
End If
Next
With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
End With
End Sub