Пакетное переименование файлов с подстановкой выделенного текста

Sub FIO()
 
    Dim r As Range, fn$, v, w As Document, fldr$
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .title = "Выбрать папку с резюме"
        .ButtonName = "Выбрать папку"
        .Filters.Clear
        .InitialFileName = ActiveDocument.Path & "\"
        If .Show = 0 Then Exit Sub
        fldr = .SelectedItems(1)
    End With
    On Error Resume Next
    With CreateObject("scripting.filesystemobject")
        For Each v In .GetFolder(fldr).Files
            Debug.Print v.Attributes
            If v.Attributes = 32 Then
                Select Case LCase(.GetExtensionName(v))
                Case "doc", "docx"
    
                    Set w = Documents.Open(v.Path, Visible:=False)
                    Set r = w.Range
                    With r.Find
                        .ClearFormatting
                        .Text = ""
                        .Font.Bold = True
                        .Replacement.Text = ""
                        .Forward = True
                        .Wrap = wdFindContinue
                        .Format = True
                        .Execute
                    End With
                    With w
                        fn = r.Text
                        If Asc(Right$(fn, 1)) < 33 Then fn = Left(fn, Len(fn) - 1)
                        fn = .Path & "\" & fn & Mid$(.Name, InStrRev(.Name, "."))
                    End With
                    If .FileExists(fn) Then
                        If MsgBox("Файл " & vbLf & fn & vbLf & " существует." & vbLf & "Продолжить ?", 68) = vbNo Then
                            Windows(w.Name).Close: Exit Sub
                        End If
                    Else
                        w.SaveAs fn
                        Windows(w.Name).Close
 
                    End If
    
                End Select
            End If
        Next
        
    End With