Открытие файлов в разных папках

Sub Process_Folders()
Dim path As Variant
Dim start_folder As Variant
Dim folders_list As Variant
Dim folders_list_arr As Variant
Dim ifn As Long
Dim nfn As Long
Dim fs As Object
Dim fl As Object
Dim f As Object
Dim fname As String
Const text_to_match As String = "*Псевдонiм*"

start_folder = "C:\Temp" 'or another user-specified folder
folders_list = FolderTree(start_folder)
folders_list_arr = Split(folders_list, vbCrLf)
nfn = UBound(folders_list_arr)
If nfn > 1 Then
    Set fs = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False
    For ifn = 0 To UBound(folders_list_arr) - 1
        'Process next folder
        Set fl = fs.GetFolder(folders_list_arr(ifn))
        For Each f In fl.files
            'Process next file
            fname = Trim(f.path)
            If fname Like "*.doc*" Then
                ChangeFileOpenDirectory fl.path
                Documents.Open FileName:=fname
                For Each p In ActiveDocument.Paragraphs
                    If p.Range.Text Like text_to_match Then
                        p.Range.Delete
                    End If
                Next
                On Error Resume Next
                ActiveDocument.Save
                On Error GoTo 0
                ActiveWindow.Close
            End If
        Next
    Next ifn
    Application.ScreenUpdating = True
    Set fs = Nothing
End If

End Sub

Function FolderTree(ByVal strFolder As Variant) As Variant
    Dim objFileSystem, objFolder, objSubFolders, objTempFolder
    Dim strArgument
    
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")

    ' Get the name of current folder
    Set objFolder = objFileSystem.GetFolder(strFolder)

    ' Get the list of subfolders
    Set objSubFolders = objFolder.SubFolders
    FolderTree = FolderTree & strFolder & vbCrLf

    ' Recursion takes place here
    ' If any "subfolders exist", the function is repeated for them too!
    If objSubFolders.count > 0 Then
        For Each objTempFolder In objSubFolders
            strArgument = strFolder & "\" & objTempFolder.name
            FolderTree = FolderTree & FolderTree(strArgument)
        Next
    End If

    Set objFileSystem = Nothing

End Function

   ActiveDocument.Save

   If ActiveDocument.ReadOnly = False Then
      ActiveDocument.Save
   End If