Автонумерация вновь созданных книг

Sub SaveCopy()
    Dim pathname$, filename$, prefix$, number&, counter&
    
    pathname = ThisWorkbook.path
    If Len(pathname) > 3 Then pathname = pathname & "\"
    filename = Dir(pathname & "*.xls", vbNormal)
    counter = 0
    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        prefix = ThisWorkbook.Worksheets(1).[A1]
        .Pattern = "^" & prefix & "\d{4}.xls$"
        Do While filename <> ""
            If (GetAttr(pathname & filename) And vbNormal) = vbNormal Then
                If .Test(filename) Then
                    number = CLng(Mid$(filename, Len(prefix) + 1, 4))
                    If number > counter Then counter = number
                End If
            End If
            filename = Dir
        Loop
        counter = counter + 1
        filename = prefix & Format(counter, "0000") & ".xls"
    End With
    ThisWorkbook.SaveCopyAs pathname & filename
End Sub

Sub макрос_в_шаблоне()
ThisWorkbook.Worksheets.Copy
With ThisWorkbook.Worksheets("Лист1") 'предполагается, что в Лист1 хранится имя новой книги в формате Имя####
  ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & .Cells(1) & ".xls"
  ActiveWorkbook.Close
  .Cells(1) = Left$(.Cells(1), Len(.Cells(1)) - 4) & Format$(Right$(.Cells(1), 4) + 1, "0000")
End With
End Sub

Sub SaveCopy()
    Dim pathname$, filename$, prefix$, number&, counter&
    
    ' Путь к папке с текущей книгой использовать для сохранения копий
    pathname = ThisWorkbook.path
    ' Добавить '\' к пути, если файл не в корневом каталоге
    If Len(pathname) > 3 Then pathname = pathname & "\"
    ' Получить префикс названия файлов из A1 на первом листе
    prefix = ThisWorkbook.Worksheets(1).[A1]
    ' Занулить счетчик нумерации копий
    counter = 0
    ' Использовать неименованный объект RegExp
    With CreateObject("VBScript.RegExp")
        ' Сравнение игнорирует регистр букв
        .IgnoreCase = True
        ' Шаблон проверки - регулярное выражение
        .Pattern = "^" & prefix & "\d{4}.xls$"
        ' Начать просмотр папки по шаблону *.xls
        filename = Dir(pathname & "*.xls", vbNormal)
        Do While filename <> ""
            ' Удостовериться, что у нас не папка, подходящая под шаблон
            If (GetAttr(pathname & filename) And vbNormal) = vbNormal Then
                ' Проверить файл на соответствие шаблону
                If .Test(filename) Then
                    ' Получить номер копии файла
                    number = CLng(Mid$(filename, Len(prefix) + 1, 4))
                    ' Сохранить максимальный номер копии
                    If number > counter Then counter = number
                End If
            End If
            ' К следующему файлу
            filename = Dir
        Loop
        ' Перевести счетчик на следующий номер
        counter = counter + 1
        ' сформировать новое имя файла
        filename = prefix & Format(counter, "0000") & ".xls"
    End With
    ' Сохранить копию файла с увеличенным на единицу счетчиком
    ThisWorkbook.SaveCopyAs pathname & filename
End Sub

Sub SaveCopy()
    Dim pathname$, filename$, prefix$, number&, counter&
    
    ' Путь к папке с текущей книгой использовать для сохранения копий
    pathname = ThisWorkbook.path
    ' Добавить '\' к пути, если файл не в корневом каталоге
    If Len(pathname) > 3 Then pathname = pathname & "\"
    ' Получить префикс названия файлов из A1 на первом листе
    prefix = ThisWorkbook.Worksheets(1).[A1]
    ' Занулить счетчик нумерации копий
    counter = 0
    ' Использовать неименованный объект RegExp
    With CreateObject("VBScript.RegExp")
        ' Сравнение игнорирует регистр букв
        .IgnoreCase = True
        ' Шаблон проверки - регулярное выражение
        .Pattern = "^" & prefix & "\d{4}.xls$"
        ' Начать просмотр папки по шаблону *.xls
        filename = Dir(pathname & "*.xls", vbNormal)
        Do While filename <> ""
            ' Удостовериться, что у нас не папка, подходящая под шаблон
            If (GetAttr(pathname & filename) And vbNormal) = vbNormal Then
                ' Проверить файл на соответствие шаблону
                If .Test(filename) Then
                    ' Получить номер копии файла
                    number = CLng(Mid$(filename, Len(prefix) + 1, 4))
                    ' Сохранить максимальный номер копии
                    If number > counter Then counter = number
                End If
            End If
            ' К следующему файлу
            filename = Dir
        Loop
        ' Перевести счетчик на следующий номер
        counter = counter + 1
        ' сформировать новое имя файла
        filename = prefix & Format(counter, "0000") & ".xls"
    End With
    ' Сохранить копию файла без макроса:
    ThisWorkbook.Worksheets.Copy ' Копировать
    ActiveWorkbook.SaveAs pathname & filename ' Сохранить
    ActiveWorkbook.Close ' Закрыть
End Sub

Sub макрос_в_шаблоне()
ThisWorkbook.Worksheets.Copy
With ThisWorkbook.Worksheets("Лист1") 'предполагается, что в Лист1 хранится имя новой книги в формате Имя####
  ActiveWorkbook.SaveAs [B]Filename:=[/B] ThisWorkbook.Path & "\" & .Cells(1) & ".xls"
  ActiveWorkbook.Close
  .Cells(1) = Left$(.Cells(1), Len(.Cells(1)) - 4) & Format$(Right$(.Cells(1), 4) + 1, "0000")
End With
End Sub