Saving as a new version if filename already exists

[aldousjg]

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:

' 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,

 

[Kenneth Hobson]

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.

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

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