Enregistrement d'une copie d'un classeur Excel existant sans l'écraser

Question

Je tente de copier un classeur Excel du dossier X vers le dossier Y, et dans le cas où un fichier de ce nom existe déjà dans le dossier Y, le fichier n'est pas écrasé mais plutôt le nouveau fichier est donné un suffixe de '- Copy', '- Copy (2)' etc - essentiellement recréer le processus manuel pour copier et coller le même fichier dans un dossier.

J'aurais pensé qu'il y aurait une fonction qui vous permet de le faire, mais rien que j'ai essayé semble à ce jour pour répondre aux exigences exactes:

• Workbook.SaveAs invite l'utilisateur avec un message demandant si le fichier doit être remplacé

• Workbook.SaveCopyAs simplement le fichier écrase sans une invite

• la méthode FileSystemObject.CopyFile a un par « écraser » AMETER, mais cela simplement des erreurs si la valeur false et le fichier existe déjà, ce qui est un comportement attendu selon le Microsoft website

Il ne serait pas difficile de créer un compteur qui incrémente en fonction du nombre de fichiers existants dans le dossier sélectionné (.xls (1), .xls (2) etc), mais j'espérais qu'il pourrait y avoir une approche plus directe que celle-ci.

Answer 1

Quelque chose comme ça peut-être? vous devrez placer un wrapper autour de lui, en affichant le fichier en tant que boîte de dialogue, puis en l'exécutant sur le chemin de fichier sélectionné.

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

Je n'ai trouvé aucune approche directe. Le code ci-dessous donnera les résultats souhaités. Il a été légèrement modifié par rapport au post précédent car l'objet fso ne fonctionnait pas pour moi.

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