Sub macro1()
Dim b(), c As Range, n%, i%
i = 1
Feuil5.Columns(1).Insert
With Feuil5
While .Cells(i, 2) <> ""
Set c = .Cells(i, 2)
If c.Font.Underline = 2 And c.Font.Color = 5855577 And IsNumeric(c) Then
n = n + 1: ReDim Preserve b(n): b(n) = c.Row
End If
i = i + 1
Wend
n = n + 1: ReDim Preserve b(n): b(n) = Feuil5.Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To UBound(b) - 1
.Cells(b(i), 1) = .Cells(b(i), 2)
.Cells(b(i), 1).AutoFill Range(.Cells(b(i), 1), Cells(b(i + 1), 1)), 1
.Cells(b(i), 1).ClearContents
If .Cells(b(i), 2).Offset(-1).Font.Underline = 2 Then .Cells(b(i), 1).Offset(-1).ClearContents
Next i
End With
With Feuil5.Columns(1)
.Font.Underline = 2
.Font.Color = 5855577
End With
End Sub