Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^13[!A-Za-z0-9~] "
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
End With
Application.ScreenUpdating = True
End Sub

Sub LoopingText() 
     'Will move to the end of each line in the document and move the text to match
     'Declare variables
    Dim outputStr As String 
    Dim currLine As String 
    Dim endChar As String 
    Dim numOfLines As Integer 
    Dim ascVal As Integer 
     'Count the number of non blank lines in current document
    numOfLines = ActiveDocument.BuiltInDocumentProperties("NUMBER OF LINES") 
     'Move to start of document
    Selection.HomeKey Unit:=wdStory 
     'Start the loop - looping once for each line
    For x1 = 1 To numOfLines 
         'MsgBox (x1)
         'ascVal = (Asc(doc.Sentences(x1).Characters(1).Text))
        ascVal = (Asc(ActiveDocument.Sentences(x1).Characters(1).Te xt)) 
         'Move to start of line
        Selection.HomeKey Unit:=wdLine 
         'Select entire line and copy into variable currLine
        Selection.EndKey Unit:=wdLine, Extend:=wdExtend 
        currLine = Selection.Range.Text 
         'Remove final character (line break) from currLine
        currLine = Left(currLine, (Len(currLine) - 1)) 
         'Check to see if character currently on end of outputStr is " " (space)
        endChar = Right(outputStr, 1) 
        If x1 = 1 Then 
             'Add the current line to the variable outputStr
             'Since this is the first run through, don't add a space
            outputStr = outputStr & currLine 
            Selection.MoveDown Unit:=wdLine, Count:=1 
            Selection.HomeKey Unit:=wdLine 
        Else 
            If Not (endChar = " ") And (((ascVal >= 65 And ascVal <= 90) Or (ascVal >= 97 And ascVal <= 122) Or (ascVal >= 48 And ascVal <= 57) Or (ascVal = 126))) Then 
                 
                 'If preceding line does not have a space at the end
                 'Add current line to the variable outputStr
                outputStr = outputStr & " " & currLine 
                Selection.EndKey Unit:=wdLine 
                Selection.TypeParagraph 
                Selection.MoveDown Unit:=wdLine, Count:=1 
                Selection.HomeKey Unit:=wdLine 
            Else 
                Selection.MoveDown Unit:=wdLine, Count:=1 
                Selection.HomeKey Unit:=wdLine 
            End If 
        End If 
         
         'Move down one line
        Selection.MoveDown Unit:=wdLine, Count:=1 
         
         'Move to the next part of the loop
    Next x1 
     'Finally 'paste' outputStr onto the document
    ActiveDocument.Range = outputStr 
    ActiveDocument.Save 
End Sub