Excel VBA Макросы: Добавить в конце имени файла порядковый номер, если файл с таким именем уже существует.

[davidoff22]

Существует следующий код:

Код

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    Range("B13:O13").Select
    ActiveWindow.SmallScroll Down:=15
    Range("B13:O13,I38:K38").Select
    Range("I38").Activate
    Selection.Replace What:="/", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    ActiveWindow.SmallScroll Down:=-12
    Selection.NumberFormat = "dd.mm.yyyy"
    ActiveWindow.SmallScroll Down:=-21
    Range("P14").Select

Dim FileName As String
   
    ' Запись в переменную имени файла без расширения.
    FileName = Sheets("Лист1").[q4].Value & " " & Sheets("Лист1").[i38].Value & " " & "на" & " " & Sheets("Лист1").[B13].Value & "-" & Sheets("Лист1").[N13].Value
    ChDir "\\Asu11-pc\e\Коррекции\Корректировки по почте"
    ActiveWorkbook.SaveAs FileName:= _
        "\\Asu11-pc\e\Коррекции\Корректировки по почте\" & FileName & ".xlsm", _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

End Sub

[свернуть]

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

Задача - если такой файл в папке уже существует, то добавлять в конце названия "-1", "-2" и т.д. - максимум может быть до 7 файлов.

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

Макрос

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    Dim FullName As String, FileName As String
   
    Range("B13:O13,I38:K38").Replace What:="/", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("B13:O13,I38:K38").NumberFormat = "dd.mm.yyyy"
   
    ' Запись в переменную имени файла.
    FileName = Sheets("Лист1").[q4].Value & " " & Sheets("Лист1").[i38].Value & " " _
        & "на" & " " & Sheets("Лист1").[B13].Value & "-" & Sheets("Лист1").[N13].Value & ".xlsm"
   
    ' Запись в переменную полного имени файла (путь + имя).
    FullName = "\\Asu11-pc\e\Коррекции\Корректировки по почте\" & FileName
   
    ' Добавление к имени файла порядкового номера.
    AddIndexToFileName FullName
   
    ' Сохранение файла.
    ActiveWorkbook.SaveAs FileName:=FullName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

End Sub

Private Sub AddIndexToFileName(FullName As String)
   
    Dim index As Long, FullNameWOExt As String, ext As String
   
   
    ' Если файла нет, то порядковый номер не добавляем.
    If Dir(FullName) = "" Then
        Exit Sub
    End If
   
    ' Запись в переменную расширения (вместе с точкой) и удаления расширения из полного имени.
    FullNameWOExt = Left(FullName, InStrRev(FullName, ".") - 1)
    ext = Mid(FullName, InStrRev(FullName, "."))
   
    ' Добавление порядкового номера к имени файла.
    ' Нумерация будет начинаться с двух, т.к. у первого не будет порядкового номера.
    index = 2
    Do
        FullName = FullNameWOExt & "-" & index & ext
        If Dir(FullNameWOExt & "-" & index & ext) = "" Then
            Exit Sub
        End If
    Loop
   
End Sub

[свернуть]