Sub CaptionBold()
Application.ScreenUpdating = False
Dim RngCap As Range
With ActiveDocument
  On Error Resume Next
  .Styles.Add "CaptionLabel", wdStyleTypeCharacter
  On Error GoTo 0
  .Styles("CaptionLabel").Font.Bold = True
  .Styles("Caption").Font.Bold = False
  With .Range
    With .Find
      .ClearFormatting
      .Text = ""
      .Style = "Caption"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .Execute
    End With
    Do While .Find.Found
      Set RngCap = .Paragraphs.Last.Range.Duplicate
      With RngCap
        .End = .Start + Len(Split(.Text, " ")(0)) + 1
        .MoveEndUntil " ", wdForward
        .Style = "CaptionLabel"
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
End With
Application.ScreenUpdating = True
End Sub