Раскладчик файлов (сохраненных по определенной маске) по нужным папкам

Option Explicit     '  Обязательное объявление переменных
Option Compare Text ' Большие и маленькие буквы в символьных переменных будут трактоваться как одинаковые.
 
Sub CopyFile()
    Dim Ext1: Ext1 = Array(".rtf", ".tif", ".jpg", ".pdf") ' Расширение архивируемых файлов
    Const Ext2$ = ".rar" ' Расширение файла архива
    ' 0 1 2 3 4 5 6 7 8 9  прямая  нумерация блоков основы имени текстового файла, начиная с 0 (без расширения)
    ' 9 8 7 6 5 4 3 2 1 0  обратная нумерация блоков основы имени текстового файла, начиная с конца с 0 (без расширения)
    ' *-*-*-*-*-*-*-*-*-*   Шаблон имени, архивируемого файла, каждый блок может быть переменной длины, блоки старших нумеров могут отсутствовать.
    Const PrymayaNumeraciya As Boolean = False ' Так как в последних служаях мы нумеруем с конца
    Const iFolger% = 1 ' Номер (от 0) папки в шаблоне имени файла
    Const iSubFolger% = 0 ' Номер (от 0) подпапки в шаблоне имени файла
    Const razd1$ = "-" ' Основной разделитель блоков в имени текстового файла
    Const razd2$ = "-" ' Дополнительный разделитель блоков в имени текстового файла, если не нужен - то сделать его одинаковым с основным.
    Const razd3$ = " " ' Еще один дополнительный разделитель блоков в имени текстового файла, если не нужен - то сделать его одинаковым с основным.
    Dim i&, j%, fso As Object, CurrFolderObject As Object, FolderObject As Object, file As Object, folder As Object, subfolder As Object
    Dim CurrFolderString$, FolderString$, Department$, DopDepartment$, WinRarApp$, ShellCommand$, FileName$, strTemp$
    Dim succes%, UserDate As Date, ArrayTemp
    If Not IsDate(Worksheets(1).Cells(5, 2).Value) Then
        MsgBox ("Не верный формат даты")
        Exit Sub
    End If
    UserDate = CDate(Worksheets(1).Cells(5, 2).Value)
    CurrFolderString = Worksheets(1).Cells(1, 2).Value
    FolderString = Worksheets(1).Cells(2, 2).Value
    WinRarApp = Worksheets(1).Cells(4, 2).Value
    If CurrFolderString = "" Or FolderString = "" Or WinRarApp = "" Then
        MsgBox ("Не все поля заполнены")
        Exit Sub
    End If
    If Trim$(CurrFolderString) = "" Or Trim$(FolderString) = "" Then
        MsgBox ("Пустые значения пути директорий")
        Exit Sub
    End If
    If Dir(CurrFolderString, vbDirectory) = "" Then
        MsgBox ("Отсутствует директория 'Каталог для обработки'")
        Exit Sub
    End If
    If Dir(FolderString, vbDirectory) = "" Then
        MsgBox ("Отсутствует директория 'Каталог для сохранения'")
        Exit Sub
    End If
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set CurrFolderObject = fso.GetFolder(CurrFolderString)
    Set FolderObject = fso.GetFolder(FolderString)
    For Each file In CurrFolderObject.Files
        strTemp = file.Name
        For i = 0 To UBound(Ext1)
            If strTemp Like "*" & Ext1(i) Then
                strTemp = Replace$(strTemp, Ext1(i), "")
                strTemp = Replace$(strTemp, razd2, razd1)
                strTemp = Replace$(strTemp, razd3, razd1)
                ArrayTemp = Split(strTemp, razd1)
                If PrymayaNumeraciya = True Then
                    Department = ArrayTemp(iFolger)
                    DopDepartment = ArrayTemp(iSubFolger)
                Else
                    Department = ArrayTemp(UBound(ArrayTemp) - iFolger)
                    DopDepartment = ArrayTemp(UBound(ArrayTemp) - iSubFolger)
                End If
                strTemp = FolderString & "\" & Department
                If Dir(strTemp, vbDirectory) = "" Then MkDir strTemp
                strTemp = FolderString & "\" & Department & "\" & DopDepartment
                If Dir(strTemp, vbDirectory) = "" Then MkDir strTemp
                fso.CopyFile CurrFolderString & "\" & file.Name, FolderString & "\" & Department & "\" & DopDepartment & "\" & file.Name, True
            End If
        Next i
    Next
    For Each folder In FolderObject.subfolders
        For Each subfolder In folder.subfolders
            FileName = Format(UserDate, "yyyy.mm.dd") & " " & Split(subfolder, "\")(UBound(Split(subfolder, "\"))) & Ext2
            If Dir(subfolder & "\" & FileName, vbNormal) <> "" Then
               fso.DeleteFile subfolder & "\" & FileName, True
            End If
            For i = 0 To UBound(Ext1)
                ShellCommand = WinRarApp & " a -ep """ & subfolder & "\" & FileName & """ """ & subfolder & "\*" & Ext1(i) & """"
                succes = Shell(ShellCommand, vbHide)
                For j = 1 To 20: DoEvents: Next
            Next i
            For Each file In subfolder.Files
                If Not file.Name Like "*" & Ext2 Then file.Delete
            Next
        Next
    Next
    MsgBox ("Готово")
End Sub

For j = 1 To 200: DoEvents: Next