Добрый день!
Как сделать макрос, который будет сохранять активный файл под новым именем?
В папке, в которой находится активный файл, есть ворд-файлы.
У файлов имена вида: 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
Большое спасибо!
Все работает отлично!
Привет всем. Что-то у меня не получается работа этого макроса. Может что-то не так в моём файле.
Если открываю файл с именем "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
Спасибо. Теперь работает правильно.