For Each iFile In Folder.Files
If iFile.Name Like

If iFile.Name Like

sInPath = "\\10.**.***.*\папка\подпапка"

Sub Макрос1()
    Workbooks.Open Filename:= _
        "\\10.**.***.*\папка\подпапка\Документ.xlsx"
    Windows("Книга1").Activate
End Sub

Sub test()
    Dim sInPath$, sOutPath$, oFSO As Object
    
    sInPath = "\\10.**.***.*\папка\подпапка"
    sOutPath = "F:\PQ\Копирование между папками\Куда"
    
    Set oFSO = CreateObject("scripting.filesystemobject")
    
    CopyRecursive oFSO, sInPath, sOutPath, "*.xls*"
        
    Set oFSO = Nothing
End Sub
Private Sub CopyRecursive(ByRef oFSO As Object, sCopyFrom$, sCopyTo$, sMask$)
    Dim oFile As Object, oFolder As Object
    Set oFolder = oFSO.GetFolder(sCopyFrom)
    For Each oFile In oFolder.Files
        If oFile.Name Like "*+*.xls*" Then oFile.Copy sCopyTo & "\" & oFile.Name
    Next
    For Each oFolder In oFolder.SubFolders
        CopyRecursive oFSO, oFolder.Path, sCopyTo, sMask
    Next
    Set oFile = Nothing
    Set oFolder = Nothing
End Sub

sInPath = "file:\\10.**.***.*\папка\подпапка"

sInPath = "file:\\10.**.***.*\папка\подпапка\"

Option Explicit
Sub test()
    Dim sInPath$, sOutPath$, oFSO As Object, sUser$, sPass$
    
    sUser = "ИмяПользователя": sPass = "Пароль" 'нужно ввести учетные данные на обменнике
    sInPath = "\\10.**.***.*\папка\подпапка"
    sOutPath = "F:\PQ\Копирование между папками\Куда"
    
    With CreateObject("WScript.Network")
        .MapNetworkDrive "", sInPath, False, sUser, sPass
        
        Set oFSO = CreateObject("scripting.filesystemobject")
        CopyRecursive oFSO, sInPath, sOutPath, "*.xls*"
        Set oFSO = Nothing
        
        .RemoveNetworkDrive sInPath, True, False
    End With
    
End Sub
Private Sub CopyRecursive(ByRef oFSO As Object, sCopyFrom$, sCopyTo$, sMask$)
    Dim oFile As Object, oFolder As Object
    Set oFolder = oFSO.GetFolder(sCopyFrom)
    For Each oFile In oFolder.Files
        If oFile.Name Like "*+*.xls*" Then oFile.Copy sCopyTo & "\" & oFile.Name
    Next
    For Each oFolder In oFolder.SubFolders
        CopyRecursive oFSO, oFolder.Path, sCopyTo, sMask
    Next
    Set oFile = Nothing
    Set oFolder = Nothing
End Sub

oFile.Copy sCopyTo & "\" & oFile.Name

sOutPath = "F:\PQ\Копирование между папками\Куда"

Option Explicit
Sub test()
          Dim sInPath$, sOutPath$, oFSO As Object, sUser$, sPass$, sFolder As Variant
10    sUser = "ИмяПользователя": sPass = "Пароль" 'нужно ввести учетные данные на обменнике
20    On Error GoTo ErrHandler
30    With Application.FileDialog(4)
40        .AllowMultiSelect = False
50        .InitialFileName = "\\10.**.***.*\папка\подпапка\"
60        .Title = "Выберите папку с файлами"
70        GoSub sel
80        sInPath = .SelectedItems(1)
90        .InitialFileName = "F:\PQ\Копирование между папками\Куда\"
100       .Title = "Выберите папку назначения"
110 sel:  If .Show = False Then
120           If MsgBox("Ничего не выбрано. Повторить?", vbYesNo) = vbYes Then
130               Resume sel
140           Else
150               Exit Sub
160           End If
170       End If
180       On Error Resume Next
190       Return
200       On Error GoTo ErrHandler
210   End With

220   With CreateObject("WScript.Network")
230       For Each sFolder In Array(sInPath, sOutPath)
240           If Left(sFolder, 2) = "\\" Then .MapNetworkDrive "", sFolder, False, sUser, sPass
250       Next

260       Set oFSO = CreateObject("scripting.filesystemobject")
270       CopyRecursive oFSO, sInPath, sOutPath, "*.xls*"
280       Set oFSO = Nothing

290       For Each sFolder In Array(sInPath, sOutPath)
300           If Left(sFolder, 2) = "\\" Then .RemoveNetworkDrive sFolder, True, False
310       Next
320   End With
330   Exit Sub
ErrHandler:
340   MsgBox "Произошла ошибка " & Err.Number & "(" & Err.Description & _
          ") в модуле " & Application.VBE.ActiveCodePane.codemodule.Name & _
          " в процедуре test() на строке " & Erl
End Sub
Private Sub CopyRecursive(ByRef oFSO As Object, sCopyFrom$, sCopyTo$, sMask$)
          Dim oFile As Object, oFolder As Object
10    On Error GoTo ErrHandler
20    Set oFolder = oFSO.GetFolder(sCopyFrom)
30    For Each oFile In oFolder.Files
40        If oFile.Name Like "*+*.xls*" Then oFile.Copy sCopyTo & "\" & oFile.Name
50    Next
60    For Each oFolder In oFolder.SubFolders
70        CopyRecursive oFSO, oFolder.Path, sCopyTo, sMask
80    Next
90    Set oFile = Nothing
100   Set oFolder = Nothing
110   Exit Sub
ErrHandler:
120   MsgBox "Произошла ошибка " & Err.Number & "(" & Err.Description & _
          ") в модуле " & Application.VBE.ActiveCodePane.codemodule.Name & _
          " в процедуре CopyRecursive() на строке " & Erl
End Sub