Word VBA Макросы: Быстрое сохранение файла с порядковым номером, учитывая номера существующих файлов

[Anton]

Добрый день!
Как сделать макрос, который будет сохранять активный файл под новым именем?

В папке, в которой находится активный файл, есть ворд-файлы.
У файлов имена вида: 05-29.12.2017 Название.расширение
Макрос должен просмотреть имена всех этих файлов, должен найти максимальный номер (в данном примере номер это "05"), затем макрос должен прибавить к максимальному номеру 1 и сохранить активный файл, с использованием этого номера. Так же макрос должен добавить текущую дату.

Если у активного файла имя вида: 05-29.12.2017 Название.расширение, то нужно удалить этот фрагмент:  05-29.12.2017, а вместо него подставить новый.

Сохранять копию нужно в ту же папку, где находится активный файл.

[Администратор]

Макрос

Sub макрос()
   
    Dim FileName As String, max As String, var
   
   
    '1. Проверка, что активный файл сохранён на жёстком диске.
        ' Иначе не известно, по какому пути сохранять.
    If ActiveDocument.Path = "" Then
        MsgBox "Активный файл не сохранён на жёстком диске, поэтому не известно, " & _
            "по какому пути сохранять копию.", vbExclamation
        Exit Sub
    End If
   
    '2. Поиск максимального номера.
    GetMaxNumber max
   
    '3. Копируем имя активного файла в переменную. Так удобнее писать код.
    FileName = ActiveDocument.Name
   
    '4. Если имя активного файла не имеет нужный вид.
    If Not FileName Like "##-##.##.## *" Then
        ' Просто добавляем спереди нужный фрагмент.
        FileName = max & "-" & Format(Date, "dd.mm.yy") & " " & FileName
    '5. Если имя активного файла имеет нужный вид.
    Else
        '1) Удаление впередистоящего текста из старого имени.
        FileName = Mid(FileName, Len("##-##.##.## ") + 1)
        '2) Добавление к имени нового номера и текущей даты.
        FileName = max & "-" & Format(Date, "dd.mm.yy") & " " & FileName
    End If
   
    '6. Создание копии активного файла.
    ActiveDocument.SaveAs2 FileName:=ActiveDocument.Path & "\" & FileName, FileFormat:=ActiveDocument.SaveFormat

End Sub

Private Sub GetMaxNumber(max As String)

    ' Поиск максимального номера.
   
    Dim FileName As String
   
   
    '1. За максимальный номер принимаем миниальный. Затем будем сравнивать с ним номера файлов.
    max = "00"
   
    '2. Поиск максимального номера.
    ' Цикл по всем файлам, которые находятся в папке, в которой находится активный файл.
    FileName = Dir(ActiveDocument.Path & "\*")
    Do While FileName <> ""
        ' Смотрим расширение файла.
        If (LCase(FileName) Like "*.doc") Or (LCase(FileName) Like "*.docx") Then
            ' Если у имени заданная структура.
            If FileName Like "##-##.##.## *" Then
                If Left(FileName, 2) > max Then
                    max = Left(FileName, 2)
                End If
            End If
        End If
        FileName = Dir
    Loop
   
    '3. Увеличение номера на 1.
    max = Format(CDbl(max) + 1, "00")

End Sub

[свернуть]

[Anton]

Большое спасибо!
Все работает отлично!

[Irina18]

Привет всем. Что-то у меня не получается работа этого макроса. Может что-то не так в моём файле.

Если открываю файл с именем "11-08.01.18 привет.docm" потом закрываю, то в папке получаю файл с именем "01-08.01.18 привет.docm", первоначально в папке этого файла не было. Далее, какой бы из этих двух файлов ни открывала и закрывала, в папке новые файлы не появляются.
У меня макрос запускается событием "Document_Close".

Прилагаю папку 22, в которой сохраняются файлы. Подскажите в чём моя ошибка.

[вложение удалено администратором]

[Администратор]

Не решение вашей задачи, просто рекомендация. Используйте всегда Option Explicit: https://forumvba.ru/index.php?topic=402.0

[Администратор]

Существующий макрос работает с файлами, у которых расширение "doc", "docx". У вас используется "docm".
Эта процедура будет работать с файлами, у которых расширение начинается "doc".
Используйте эту процедуру вместо прежней.

Код

Private Sub GetMaxNumber(max As String)

    ' Поиск максимального номера.
   
    Dim FileName As String
   
   
    '1. За максимальный номер принимаем миниальный. Затем будем сравнивать с ним номера файлов.
    max = "00"
   
    '2. Поиск максимального номера.
    ' Цикл по всем файлам, которые находятся в папке, в которой находится активный файл.
    FileName = Dir(ActiveDocument.Path & "\*.doc*")
    Do While FileName <> ""
        ' Если у имени заданная структура.
        If FileName Like "##-##.##.## *" Then
            If Left(FileName, 2) > max Then
                max = Left(FileName, 2)
            End If
        End If
        FileName = Dir
    Loop
   
    '3. Увеличение номера на 1.
    max = Format(CDbl(max) + 1, "00")
   
End Sub

[свернуть]

[Irina18]

Спасибо. Теперь работает правильно.