Sub CaptionBold()
Application.ScreenUpdating = False
Dim Shp As Shape
With ActiveDocument
  On Error Resume Next
  .Styles.Add "CaptionLabel", wdStyleTypeCharacter
  On Error GoTo 0
  .Styles("CaptionLabel").Font.Bold = True
  .Styles("Caption").Font.Bold = False
  Call Processor(.Range)
  For Each Shp In .Shapes
    If Not Shp.TextFrame Is Nothing Then
      With Shp.TextFrame
        .TextRange.InsertAfter vbCr
        .TextRange.Paragraphs.Last.Style = "Normal"
        Call Processor(.TextRange)
        .TextRange.Characters.Last.Delete
      End With
    End If
  Next
End With
Application.ScreenUpdating = True
End Sub
 
Sub Processor(Rng As Range)
With Rng
  With .Find
    .ClearFormatting
    .Text = ""
    .Style = "Caption"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
  Do While .Find.Found
    With .Paragraphs.Last.Range.Duplicate
      .End = .Start + Len(Split(.Text, " ")(0)) + 1
      .MoveEndUntil " ", wdForward
      .Style = "CaptionLabel"
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
End Sub