Sub Fees()
Application.ScreenUpdating = False
Dim StrOut As String, DocNew As Document
With ActiveDocument
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchWildcards = True
      .Text = "(US [3-9]),([0-9]{3}),([0-9]{3})"
      .Replacement.Text = "\1\2\3"
      .Execute Replace:=wdReplaceAll
      .Text = "(US )([0-9]{5} )"
      .Replacement.Text = "\1RE\2"
      .Execute Replace:=wdReplaceAll
      .Wrap = wdFindStop
      .Text = "US [R3-9][0-9E]{6}"
      .Replacement.Text = ""
      .Execute
    End With
    Do While .Find.Found
      StrOut = StrOut & Split(.Text, " ")(1) & vbCr
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
End With
Set DocNew = Documents.Add
With DocNew
  .Range.Text = StrOut
  .SaveAs2 FileName:="C:\Users\" & Environ("Username") & "\Desktop\i.txt", _
    FileFormat:=wdFormatText, AddToRecentFiles:=False
  .Close
End With
Set DocNew = Nothing
Application.ScreenUpdating = True
End Sub