Saving a copy of an existing Excel workbook without overwriting it

Question

I am trying to copy an Excel workbook from Folder X to Folder Y, and in the event that a file of that name already exists in Folder Y, the file is not overwritten but rather the new file is given a suffix of '- Copy', '- Copy (2)' etc - essentially recreating the manual process for copying and pasting the same file in a folder.

I would have thought that there would be a function that allows you to do this but nothing I have tried so far seems to fit the exact requirements:

• Workbook.SaveAs prompts the user with a message asking whether the file should be replaced

• Workbook.SaveCopyAs simply overwrites the file without a prompt

• The FileSystemObject.CopyFile method has an 'overwrite' parameter, however this simply errors if set to false and the file already exists, which is expected behaviour according to the Microsoft website

It wouldn't be difficult to create a counter which increments based on the number of existing files in the selected folder (.xls (1), .xls (2) etc), but I hoped that there might be a more direct approach than this.

Answer 1

The Function worked for me but after two steps.

Step 1 :

Go into the VBE's Menu (Tools -> References) and then place a check mark beside "Microsoft Scripting Run-time".

Step 2 :

Edit the code, as it was :

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

And I guessed you must INSERT INSIDE THE LOOP a line to update the new filename as to be checked if exists. So the new Code should be :

   Do
       blnNotFound = FileExists(strNewFileName)
       If blnNotFound Then intCounter = intCounter + 1
       ' HERE :
       strNewFileName = fl.ParentFolder & "\" & strFileNameNoExt & " (" & intCounter & ")." & strExtension

   Loop Until Not blnNotFound

GOOD JOB AND THANK YOU.

Answer 2

Something like this maybe? you'll need to put a wrapper round it, showing the file save as dialog, then run this off the selected filepath.

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 3

I did not find any direct approach. Below code will give the desired results. It was slightly modified from previous post as fso object did not work for me.

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