Sub Gras()
Dim t, i&, c As Range, x$, j%
Application.ScreenUpdating = False
With [A1].CurrentRegion.Offset(1).Resize(, 2) 'au moins 2 cellules
t = .Value 'matrice, plus rapide
For i = 1 To .Rows.Count - 1
Set c = .Cells(i, 1): x = t(i, 1): t(i, 1) = ""
For j = 1 To Len(x)
If c.Characters(j, 1).Font.Bold Or Mid(x, j, 1) = vbLf Then t(i, 1) = t(i, 1) & Mid(x, j, 1)
Next j, i
.Copy .Offset(, 4) 'en colonne E
With .Offset(, 4)
.Value = t
.Font.Bold = True
End With
End With
End Sub