XL 2010 extraire des mots en gras

Sub Entrer_Mots_Gras()
    Dim T, cel As Range, tb
    T = Timer
    Application.ScreenUpdating = False
    [B1].Resize(Rows.Count, 6).ClearContents
    With ActiveSheet.UsedRange
        For Each cel In .Cells
            tb = Mots_Gras(cel)
            cel.Offset(, 1).Resize(, UBound(tb)) = tb
        Next
    End With
    MsgBox "Durée " & Format(Timer - T, "0.00 \sec")
End Sub
Sub testInstrdoloop()
     Mots_Gras$ ([A3])
End Sub
Function Mots_Gras(c As Range)
    Dim x$, s, I%, n%, pos&, z&, s2
    x = c.Value & " "
    s = Split(x)
     ReDim s2(1 To UBound(s))
    If UBound(s) = 0 Then Exit Function
    pos = 1
    For I = 0 To UBound(s)
        z = InStr(pos, c.Value, s(I))
         If c.Characters(z, 1).Font.Bold = True Then n = n + 1: s2(n) = s(I):
        pos = pos + Len(s(I))
    Next
     Mots_Gras = s2
End Function

Option Explicit

Sub Entrer_Mots_Gras()
    Dim T, tb, Rng As Range
    T = Timer
    [B1].Resize(Rows.Count, 150).ClearContents
    Set Rng = ActiveSheet.UsedRange
    tb = Mots_Gras(Rng)
    Rng.Offset(, 1).Resize(, UBound(tb)) = tb


    MsgBox "Durée " & Format(Timer - T, "0.00 \sec")
End Sub


Function Mots_Gras(Rng As Range)
    Dim x, I%, n%, pos&, z&, a&, tbl2
    ReDim tbl2(1 To Rng.Rows.Count, 20)
    For I = 1 To UBound(tbl2)
        x = Split(Rng.Cells(I, 1).Value)
        pos = 1
        n = 0
        For a = 0 To UBound(x)
            z = InStr(pos, Rng.Cells(I, 1), x(a))
            If Rng.Cells(I, 1).Characters(z, 1).Font.Bold = True Then n = n + 1: tbl2(I, n) = x(a)
            pos = pos + Len(x(a))
        Next
    Next
    Mots_Gras = tbl2
End Function