Сохранение файла Word с именем, взятым из данных самого файла

Sub AutoClose()
Dim i As Long       'счётчик искомых последовательностей из 5 цифр
Dim verdict As Long 'ответ оператора
 
With Selection
.HomeKey wdStory                'ищем (имя) с начала документа
.Find.Wrap = wdFindStop         'поиск производим с остановкой на найденном
    Do
    .Find.Text = "^#^#^#^#^#"   'равносильно CTRL-F и там набрать ^#^#^#^#^#
    .Find.Execute               'здесь выделены (если есть) очередные 5 цифр текста
    
    verdict = MsgBox("Сохраняю " & ActiveDocument & " как " & .Text, vbOKCancel)
    
        If verdict = vbOK And .Text Like "#####" Then
            ActiveDocument.SaveAs .Text 'сохранили как <найденное в нем число>.doc[x]
            Exit Sub
        Else
            Exit Sub
'            Exit Do
'          Если открыть Exit Do, закрыв Exit Sub, будет появляться сообщение (рис. 2)
        End If
    
    i = i + 1
    Loop Until Not .Find.Found
End With
    If i = 0 Then MsgBox "Новое имя в " & ActiveDocument & " не найдено."
End Sub