Sub test()
    Dim cell As Range
    Путь = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "")
    For Each cell In Selection.Cells
        SaveTXTfile Путь & cell.Address & ".txt", cell
    Next cell
End Sub

Function SaveTXTfile(ByVal filename As String, ByVal txt As String) As Boolean
    On Error Resume Next: Err.Clear
    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.CreateTextFile(filename, True)
    ts.Write txt: ts.Close
    SaveTXTfile = Err = 0
    Set ts = Nothing: Set fso = Nothing
End Function

Public Function RegExpExtract(Text As String, Pattern As String, Optional Item As Integer = 1) As String
     On Error GoTo ErrHandl
     Set regex = CreateObject("VBScript.RegExp")
     regex.Pattern = Pattern
     regex.Global = True
     If regex.Test(Text) Then
         Set matches = regex.Execute(Text)
         RegExpExtract = matches.Item(Item - 1)
         Exit Function
     End If
 ErrHandl:
     RegExpExtract = CVErr(xlErrValue)
 End Function

=ПСТР(строка_поиска;НАЙТИ("№";строка_поиска;1);НАЙТИ(" ";строка_поиска;НАЙТИ("№";строка_поиска;1))-НАЙТИ("№";строка_поиска;1))