Option Explicit
'Option Base 1

Dim FSO As Object, SourceFolder As Object, SubFolder As Object, FileItem As Object
'Dim r As Long
'Dim arrFileName() As String
Dim sFold01 As String, sFold02 As String, sKeyWor As String
Dim sNewFolder As String

Sub InExSu_ПереносФайлов_ПоСимволамВИмени()
  Call getSettings
  Call MoveFolder(sFold01, sFold02, sKeyWor)
  'Call moveFiles
End Sub
Sub getSettings()
  With ThisWorkbook.Worksheets("Лист3")
    sFold01 = .Range("d6").Value
    sFold02 = .Range("f6").Value
    sKeyWor = .Range("h4").Value
  End With
End Sub
Sub MoveFolder(ByVal sFold01, ByVal sFold02, ByVal sKeyWor)
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set SourceFolder = FSO.getfolder(sFold01)
  For Each SubFolder In SourceFolder.SubFolders 'для каждой вложенной папки
    With CreateObject("Scripting.FileSystemObject")
      If InStr(SubFolder, sKeyWor) Then
        sNewFolder = Replace(SubFolder, sFold01, sFold02)
        If .FolderExists(sNewFolder) = False Then _
          .getfolder(SubFolder).Move sNewFolder 'в существующую папку файлы не добавляются
      End If
    End With
  Next SubFolder
End Sub