Sub subFindTextAndMoveItToEndOfTheSameParagraphAndUnderlineIt()
Dim oRng As Range
Dim oRngParent As Range
Dim strText As String
  strText = "Falsification  45 C.F.R. ?" & Chr(160) & "6891(a)(2):  "
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .ClearFormatting
    .Text = strText
    .Forward = True
    .Wrap = wdFindStop
    While .Execute
      With oRng
        .Select 'Why do you need to select it?
        .Text = Trim(.Text)
        .Font.Underline = wdUnderlineSingle
        Set oRngParent = .Paragraphs(1).Range
        With oRngParent
          .Characters.Last.Previous.InsertAfter " "
          .MoveEnd wdCharacter, -1
          .Collapse wdCollapseEnd
        End With
        .Cut
        With oRngParent
          .Paste
          .Characters.Last.Delete
          .Start = oRngParent.Paragraphs(1).Range.Start
          .Characters.First.Case = wdUpperCase
        End With
        .Start = oRngParent.End
      End With
    Wend 
  End With
End Sub