Создать новые и переместить старые листы

Option Explicit
 
Dim Fname: Fname = "Z:\Soft_Out\Frm.xls"        ' Имя файла для обработки
Dim FoldArc: FoldArc = "Z:\Box_Out"             ' Имя папки для архива
 
Dim R, Rall: Rall = "A2:R700"                    'Диапазон ячеек с данными
 
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim nMonth: nMonth = Array(MonthName(12), MonthName(1), MonthName(2), MonthName(3), MonthName(4), MonthName(5), MonthName(6), MonthName(7), MonthName(8), MonthName(9), MonthName(10), MonthName(11), MonthName(12), MonthName(1))
Dim i, j, wbName, nSheets, wsName, wName, yName
 
With CreateObject("Scripting.FileSystemObject")
    If Not FSO.FileExists(Fname) Then
        MsgBox "Файл" + vbCr + Fname + vbCr + "не найден"
        Script.Quit    'Exit Sub    'WScript.Quit  '
    Else
        .CopyFile Fname, FoldArc + "\" + CStr(Year(Now)) + CStr(Month(Now)) + CStr(Day(Now)) + CStr(Hour(Now)) + CStr(Minute(Now)) + "-" + .GetFileName(Fname)
    End If
End With
 
Dim XLS: Set XLS = CreateObject("Excel.Application")
With XLS
    .Visible = True  'False  '
    .Workbooks.Open (Fname)
    wbName = .ActiveWorkbook.Name
    nSheets = .Worksheets.Count
 
    .Application.ScreenUpdating = False  '''''''''True      '
    With .Workbooks(wbName)
    For i = nSheets To 2 Step -1
        wsName = .Worksheets(i).Name
        For j = 1 To 12
            wName = Split(.Worksheets(i).Name, " ")(0)
            yName = CInt(Split(.Worksheets(i).Name, " ")(1))
            If UCase(nMonth(j)) = UCase(wName) Then
                If j = 12 Then
                    .Worksheets(i).Name = nMonth(j + 1) + " " + CStr(yName + 1)
                Else
                    .Worksheets(i).Name = nMonth(j + 1) + " " + CStr(yName)
                End If
                Exit For
            End If
        Next
        
    Next
    
    For i = 2 To nSheets - 1
        .Worksheets(i + 1).Range(Rall).Copy
        .Worksheets(i).Range(Rall).PasteSpecial
        .Sheets(i).Select
        .Worksheets(i).Range("A1").Select
    Next
 
    .Sheets(nSheets).Select
' Закоментирована поклеточная очистка нового месяца c анализом наличия формул - медленно
'    For Each R In .Worksheets(nSheets).Range(Rall)
'        If Not R.HasFormula Then R.ClearContents
'    Next
    .Worksheets(nSheets).Range(Rall).ClearContents          'Очистка контента всего диапазона
    End With
 
    .Application.ScreenUpdating = True
    MsgBox "Done"
End With