Saving as a new version if filename already exists

aldousjg

New Member
Joined
Jan 20, 2021
Messages
12
Office Version
  1. 365
Platform
  1. Windows
Hi all,

I'm trying to write VBA code to save a file as V2 if V1 already exists, or V3 if V2 already exists etc. My code creates a directory if it doesn't already exist, then saves the file in that directory:

VBA Code:
' Declare variables

    Dim directoryname As String
    Dim filename1 As String
    Dim fullfilename As String
    
' Set "directoryname" as folder location
    
    directoryname = _
        Application.Workbooks(1).Path & "\" & Workbooks(1).Sheets("Macro").Range("J9").Text & "\" & _
        Workbooks(1).Sheets("Macro").Range("J9").Text & " SUR Reports " & _
        Format(Workbooks(1).Sheets("Macro").Range("L9"), "yyyy-mm-dd") & " to " & _
        Format(Workbooks(1).Sheets("Macro").Range("N9"), "yyyy-mm-dd") & "\"
      
' If folder location does not already exist then create it, if it does exist do nothing

    If Dir(directoryname, vbDirectory) = "" Then
        MkDir (directoryname)
    Else
    End If
    
' Extract and save report

    ThisWorkbook.Activate
    Sheets("Summary 2").Select
    Sheets("Summary 2").Copy
    Sheets("Summary 2").Cells.Copy
    Sheets("Summary 2").Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    If Workbooks(1).Sheets("Macro").Range("J9").Value = "Daily" Then
        filename1 = ThisWorkbook.Sheets("Macro").Range("H9").Text & " " & ThisWorkbook.Sheets("Macro").Range("J9").Text & _
        " SUR " & Format(ThisWorkbook.Sheets("Macro").Range("L9"), "yyyy-mm-dd") & ".xlsx"
    Else
        filename1 = ThisWorkbook.Sheets("Macro").Range("H9").Text & " " & ThisWorkbook.Sheets("Macro").Range("J9").Text & _
        " SUR " & Format(ThisWorkbook.Sheets("Macro").Range("L9"), "yyyy-mm-dd") _
        & " to " & Format(ThisWorkbook.Sheets("Macro").Range("N9"), "yyyy-mm-dd") & ".xlsx"
    End If

    ActiveWorkbook.SaveAs filename:=directoryname & filename1, FileFormat:=xlOpenXMLWorkbook

My attempts at using a loop to check if file already exists then add a version number if it does have been unssuccessful.

Is anyone able to help?

Thanks,
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

Kenneth Hobson

Well-known Member
Joined
Feb 6, 2007
Messages
3,172
Office Version
  1. 365
Platform
  1. Windows
I am not sure how your naming convention works. It might be first is base.ext and second as base v2.ext. Or first as base v1.ext and second as base v2.ext.

If it were me, I would let Windows set the names sort of like it does with multiple copies. e.g. base.ext, base (2).ext or base (1).ext, base (2).ext.

There are two ways to do that using API's as shown above. Put these into a Module. The test subs can go into the same Module or another. Pick the API method that you like best.

VBA Code:
Option Explicit
'This kb article:
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=1041

'Another sequential filename
'tstav,http://vbaexpress.com/kb/getarticle.php?kb_id=1008

Const Max_Path As String = 260
'http://msdn.microsoft.com/en-us/library/bb776479.aspx

'64bit APIs, VBA7
Public Declare PtrSafe Function PathYetAnotherMakeUniqueName _
  Lib "shell32.dll" _
  ( _
  ByVal pszUniqueName As String, _
  ByVal pszPath As String, _
  ByVal pszShort As String, _
  ByVal pszFileSpec As String _
  ) As Boolean

'http://msdn.microsoft.com/en-us/library/bb776479.aspx
Public Declare PtrSafe Function PathMakeUniqueName _
  Lib "shell32.dll" _
  ( _
  ByVal pszUniqueName As String, _
  ByVal cchMax As Long, _
  ByVal pszTemplate As String, _
  ByVal pszLongPlate As String, _
  ByVal pszDir As String _
  ) As Boolean


Function fMakeAnotherUnique(vShortTemplate, vLongTemplate, vFolder) As String
  'vFolder can end in trailing backslash or not
  Dim rc As Boolean, vUniqueName As String, s As String
  vUniqueName = Space$(Max_Path)
  rc = PathYetAnotherMakeUniqueName(vUniqueName, StrConv(vFolder, vbUnicode), _
    StrConv(vShortTemplate, vbUnicode), StrConv(vLongTemplate, vbUnicode))
  If rc Then
    vUniqueName = StrConv(vUniqueName, vbFromUnicode)
    fMakeAnotherUnique = vUniqueName
  End If
End Function

Function MakeAnotherUnique(filespec As String) As String
  MakeAnotherUnique = fMakeAnotherUnique("", GetFileName(filespec), GetFolderName(filespec))
End Function

Function fMakeUnique(vShortTemplate, vLongTemplate, vFolder) As String
  'vFolder can end in trailing backslash or not
  Dim rc As Boolean, vUniqueName As String, s As String
  vUniqueName = Space$(Max_Path)
  rc = PathMakeUniqueName(vUniqueName, Max_Path, StrConv(vShortTemplate, vbUnicode), _
    StrConv(vLongTemplate, vbUnicode), StrConv(vFolder, vbUnicode))
  If rc Then
    vUniqueName = StrConv(vUniqueName, vbFromUnicode)
    fMakeUnique = vUniqueName
  End If
End Function

Function MakeUnique(filespec As String) As String
  MakeUnique = fMakeUnique("", GetFileName(filespec), GetFolderName(filespec))
End Function

Function GetFileName(filespec As String) As String
  Dim p1 As Integer, p2 As Integer
  p1 = InStrRev(filespec, "\")
  p2 = Len(filespec) - p1
  GetFileName = Mid$(filespec, p1 + 1, p2)
End Function

Function GetFolderName(filespec As String) As String
  Dim p1 As Integer
  p1 = InStrRev(filespec, "\")
  GetFolderName = Left$(filespec, p1)
End Function

VBA Code:
Sub Test1()
  Dim s As String
  s = fMakeAnotherUnique("", Environ("username") & ".xlsm", ThisWorkbook.Path)
  MsgBox s, vbInformation, "MsgBox1: fMakeAnotherUnique()"
  s = fMakeAnotherUnique("", ThisWorkbook.Name, ThisWorkbook.Path)
  MsgBox s, vbInformation, "MsgBox2: fMakeAnotherUnique()"
End Sub

Sub Test2()
  Dim s As String
  s = MakeAnotherUnique(ThisWorkbook.Path & "\" & Environ("username") & ".xlsm")
  MsgBox s, vbInformation, "MsgBox3: MakeAntoherUnique()"
  s = MakeAnotherUnique(ThisWorkbook.FullName)
  MsgBox s, vbInformation, "MsgBox4: MakeAntoherUnique()"
End Sub

Sub Test3()
  Dim s As String
  s = fMakeUnique("", Environ("username") & ".xlsm", ThisWorkbook.Path)
  MsgBox s, vbInformation, "MsgBox5: fMakeUnique()"
  s = fMakeUnique("", ThisWorkbook.Name, ThisWorkbook.Path)
  MsgBox s, vbInformation, "MsgBox6: fMakeUnique()"
End Sub


Sub Test4()
  Dim s As String
  s = MakeUnique(ThisWorkbook.Path & "\" & Environ("username") & ".xlsm")
  MsgBox s, vbInformation, "MsgBox7: MakeUnique()"
  s = MakeUnique(ThisWorkbook.FullName)
  MsgBox s, vbInformation, "MsgBox8: MakeUnique()"
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,129,673
Messages
5,637,718
Members
416,981
Latest member
PLonchar

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top