Hi, I created this from some of the comments posted here.
Why does the "For Each...Next" loop through the whole document and not just
the selection?

Sub NumSR()

Dim rSlc As Range ' selection range
Dim rTmp As Range ' temporary range
Dim oPrg As Paragraph
Set rSlc = Selection.Range

For Each oPrg In rSlc.Paragraphs
  Set rTmp = oPrg.Range
  With rTmp.Find
  .Text = "([^32^t^s]{1,})^13"
  .MatchWildcards = True
  .Execute
  End With
 
  If rTmp.Find.Found Then
   With rTmp.Find
  .Text = "([^32^t^s]{1,})^13"
  .Replacement.Text = "^t^p"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
   End With
  End If

  With rTmp.Find
  .Text = "([0-9]{1,})([^32^t^s]{1,})^13"
  .MatchWildcards = True
  .Execute
  End With
 
  If rTmp.Find.Found Then
   With rTmp.Find
  .Text = "([0-9]{1,})([^32^t^s]{1,})^13"
  .Replacement.Text = "^p"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
   End With
  End If

  With rTmp.Find
  .Text = "([0-9]{1,})^13"
  .MatchWildcards = True
  .Execute
  End With
 
  If rTmp.Find.Found Then
   With rTmp.Find
  .Text = "([0-9]{1,})^13"
  .Replacement.Text = "^p"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
   End With
  End If

Next

Dim i As Long
With rSlc
   For i = 1 To .Paragraphs.Count
       Set rTmp = .Paragraphs(i).Range
       rTmp.End = rTmp.End - 1
       rTmp.Text = rTmp.Text & i
   Next i
End With
   
End Sub