Сохранение копии существующей книги Excel без ее перезаписи

Question

Я пытаюсь скопировать книгу Excel из папки X в папку Y, а в случае, если файл этого имени уже существует в папке Y, файл не перезаписывается но новому файлу присваивается суффикс '- Copy', '- Copy (2)' и т. д. - по существу, воссоздание ручного процесса для копирования и вставки одного и того же файла в папку.

я бы подумал, что было бы функция, которая позволяет это сделать, но ничего я пытался до сих пор, кажется, чтобы соответствовать конкретным требованиям:

• Workbook.SaveAs предлагает пользователю сообщение с запросом о файл должен быть заменен

• Workbook.SaveCopyAs просто перезаписывает файл без запроса

• The FileSystemObject.CopyFile метод имеет «перезаписать» пар ameter, однако это просто ошибки, если значение ЛОЖЬ и файл уже существует, который, как ожидается, поведение в соответствии с Microsoft website

Это не было бы трудно создать счетчик, который получает приращение на основе количества существующих файлов в выбранной папке (.xls (1), .xls (2) и т. д.), но я надеялся, что может быть более прямой подход, чем этот.

Answer 1

Что-то вроде этого, может быть? вам нужно поместить обертку вокруг него, показывая диалог сохранения файла в диалоговом окне, а затем запустите это с выбранного пути к файлу.

Public Function CUSTOM_SAVECOPYAS(strFilePath As String) 

Dim FSO As Scripting.FileSystemObject 
Dim fl As Scripting.File 
Dim intCounter As Integer 
Dim blnNotFound As Boolean 
Dim arrSplit As Variant 
Dim strNewFileName As String 
Dim strFileName As String 
Dim strFileNameNoExt As String 
Dim strExtension As String 

arrSplit = Split(strFilePath, "\") 

strFileName = arrSplit(UBound(arrSplit)) 
strFileNameNoExt = Split(strFileName, ".")(0) 
strExtension = Split(strFileName, ".")(1) 

Set FSO = New Scripting.FileSystemObject 

intCounter = 1 

If FSO.FileExists(strFilePath) Then 
    Set fl = FSO.GetFile(strFilePath) 
    strNewFileName = fl.Path & "\" & strFileNameNoExt & " (" & intCounter & ")." & strExtension 
    Do 
     blnNotFound = Not FSO.FileExists(strNewFileName) 
     If Not blnNotFound Then intCounter = intCounter + 1 
    Loop Until blnNotFound 
Else 
     strNewFileName = strFilePath  
End If 

ThisWorkbook.SaveCopyAs strNewFileName 
set fso=nothing 
set fl =nothing 

End Function 

Answer 2

Я не нашел прямого подхода. Ниже код даст желаемые результаты. Он немного изменился с предыдущего поста, поскольку объект fso не работал для меня.

Public Function CUSTOM_SAVECOPYAS_FILENAME(strFilePath As String) As String 
Dim intCounter As Integer 
Dim blnNotFound As Boolean 
Dim arrSplit As Variant 
Dim strNewFileName As String 
Dim strFileName As String 
Dim strFileNameNoExt As String 
Dim strExtension As String 
Dim pos As Integer 
Dim strFilePathNoFileName As String 
arrSplit = Split(strFilePath, "\") 

pos = InStrRev(strFilePath, "\") 
strFilePathNoFileName = Left(strFilePath, pos) 

strFileName = arrSplit(UBound(arrSplit)) 
strFileNameNoExt = Split(strFileName, ".")(0) 
strExtension = Split(strFileName, ".")(1) 


intCounter = 1 

If FileExists(strFilePath) = True Then 
    'Set fl = FSO.GetFile(strFilePath) 
    strNewFileName = strFilePathNoFileName & strFileNameNoExt & " (" & intCounter & ")." & strExtension 
    Do 
     blnNotFound = FileExists(strNewFileName) 
     If blnNotFound Then intCounter = intCounter + 1 
    Loop Until Not blnNotFound 
Else 
     strNewFileName = strFilePath 
End If 

'This function will return file path to main function where you save the file 
CUSTOM_SAVECOPYAS_FILENAME = strNewFileName 

End Function 

Public Function FileExists(ByVal path_ As String) As Boolean 
FileExists = (Len(Dir(path_)) > 0) 
End Function 

'main 
Sub main() 
'....... 
str_fileName = "C:/temp/test.xlsx" 
str_newFileName = CUSTOM_SAVECOPYAS_FILENAME(str_fileName) 

Application.DisplayAlerts = False 
NewWb.SaveAs str_newFileName 
NewWb.Close 
Application.DisplayAlerts = True 
End Sub