Sub SubscriptPara()
    Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        
        With .Replacement.Font
            .Bold = True
            .Color = vbBlack
            .Superscript = True
            .Size = 10
        End With
        
        .Text = "[0-9]{1,} "
        .Replacement.Text = "^&"
        .Execute Replace:=wdReplaceAll

        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
End Sub

Sub SubscriptPara()
    Selection.HomeKey wdStory 
    
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "[0-9]{1,} "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
        Do While .Execute
            If MsgBox("Subscript here?", vbYesNo) = vbYes Then
                With Selection.Range.Font
                    .Bold = True
                    .Color = vbBlack
                    .Superscript = True
                    .Size = 10
                End With
            End If
        Loop

    End With
End Sub

Sub SubscriptPara()
    Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    Dim a As String
    With Selection.find
        .ClearFormatting
        .Replacement.ClearFormatting
        With .Replacement.font
            .Bold = True
            .Color = vbBlack
            .Superscript = True
            .Size = 10
        End With
        
        .Text = "[0-9]{1,} "
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .format = True
        .MatchWildcards = True
    Do While .Execute = True
        a = MsgBox("Do you want the selection to be subscriptted?", vbYesNoCancel)
        If a = vbYes Then
            .Execute Replace:=wdReplaceOne
        ElseIf a = vbNo Then
            .Execute
        Else
            Exit Sub
        End If
    Loop
    End With
End Sub

Sub FindNum()
Dim oRng As Range
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .ClearFormatting
    .Font.Superscript = False 'Don't find if already superscripted
    .Text = "[0-9]{1,} "
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchWildcards = True
    Do While .Execute
      oRng.Select
      Select Case MsgBox("Do you want the numbers found in the current paragraph to be subscripted?", vbYesNoCancel)
        Case vbYes
          SubscriptPara oRng.Paragraphs(1).Range
         Case vbNo
          oRng.End = oRng.Paragraphs(1).Range.End
        Case Else: Exit Sub
      End Select
      oRng.Collapse wdCollapseEnd
    Loop
  End With
lbl_Exit:
  Exit Sub
End Sub
Sub SubscriptPara(oRng As Range)
Dim oRngPar As Range
  Set oRngPar = oRng.Duplicate
  With oRng.Find
    .ClearFormatting
    .Font.Superscript = False 'Don't find if already superscripted
    .Text = "[0-9]{1,} "
    .MatchWildcards = True
     Do While .Execute
      If oRng.InRange(oRngPar) Then
        With oRng.Font
          .Bold = True
          .Color = vbBlack
          .Superscript = True
          .Size = 10
        End With
      Else
        Exit Do
      End If
      oRng.Collapse wdCollapseEnd
    Loop
  End With
lbl_Exit:
  Exit Sub
End Sub

Sub Demo()
Dim oRng As Range
  Set oRng = ActiveDocument.Range
  On Error GoTo Err_Handler
  Err.Raise 6
  MsgBox "You won't see this message"
lbl_Exit:
  Set oRng = Nothing
  Exit Sub
Err_Handler:
  MsgBox "An error has occurred"
  Resume lbl_Exit
End Sub