Sub Macro1()
Dim oRng As Range
    Set oRng = ActiveDocument.Range
    With oRng.Find
        Do While .Execute(FindText:="[0-9]{1,}", MatchWildcards:=True)
            If Not oRng.Start = oRng.Paragraphs(1).Range.Start And _
               Not oRng.End = oRng.Paragraphs(1).Range.End - 1 Then
                oRng.InsertParagraphBefore
                oRng.Collapse 0
            End If
        Loop
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub