Save document as new version with specific format

[tanko]

I want to create a macro that will save a document as a new version. Documents in my company are named like "Master Agreement 01 (JPM 04.03.21)" where the "01" is the version number, "JPM" are the initials of the author, and of course "04.03.21" is the date.



I found the code at the bottom of this post on another site, and have been tinkering with it, but I keep getting thrown by InStrRev not finding a string with multiple variables. That is, I would think that the following code would return the version number in the above filename, but it does not.

Sub FileVerTest()

Dim VersionExt As String
Dim VerFind As String
Dim myFileName As String

myFileName = ActiveDocument.Name

VerFind = "[1-9] & Chr(0)"

'Finds version of current document, assuming doc is named like "[name] 01 ([initials] [date])"
VersionExt = Mid(myFileName, InStr(myFileName, VerFind, 2))


MsgBox VersionExt

End Sub

Why isn't this working? I've tried all kinds of VerFind strings, and nothing I do seems to make it work. I'm trying to learn VBA so I'd like to be able to write this one out, but I'm struggling.

Here is the code I found elsewhere that I would like to modify for this use. Also, here's a fun challenge, some people at my company use different formats like "Master Agreement02(JPM 04.03.21)" or "Master Agreement 02.1 (JPM 040321)". Once I get the basic code figured out, I think I can modify to meet each of those different naming styles.

Sub SaveNewVersion_Word()
'PURPOSE: Save file, if already exists add a new version indicator to filename
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault

Dim FolderPath As String
Dim myPath As String
Dim SaveName As String
Dim SaveExt As String
Dim VersionExt As String
Dim Saved As Boolean
Dim x As Long
Dim todayDate As String
Dim myInitials As String

myInitials = "DSR"
todayDate = Format(Date, "MM.DD.YY")

TestStr = ""
Saved = False
x = 2

'Version Indicator (change to liking)
  VersionExt = "_v"

'Pull info about file
  On Error GoTo NotSavedYet
    myPath = ActiveDocument.FullName
    myFileName = Mid(myPath, InStrRev(myPath, "\") + 1, InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
    FolderPath = Left(myPath, InStrRev(myPath, "\"))
    SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
  On Error GoTo 0

'Determine Base File Name
  If InStr(1, myFileName, VersionExt) > 1 Then
    myArray = Split(myFileName, VersionExt)
    SaveName = myArray(0)
  Else
    SaveName = myFileName
  End If
    
'Test to see if file name already exists
  If FileExist(FolderPath & SaveName & SaveExt) = False Then
    ActiveDocument.SaveAs FolderPath & SaveName & SaveExt
    Exit Sub
  End If
  
      
'Need a new version made
  Do While Saved = False
    If FileExist(FolderPath & SaveName & VersionExt & x & SaveExt) = False Then
      ActiveDocument.SaveAs FolderPath & SaveName & VersionExt & x & SaveExt
      Saved = True
    Else
      x = x + 1
    End If
  Loop

'New version saved
  MsgBox "New file version saved (version " & x & ")"

Exit Sub

'Error Handler
NotSavedYet:
  MsgBox "This file has not been initially saved. " & _
    "Cannot save a new version!", vbCritical, "Not Saved To Computer"

End Sub

[gmayor]

The following will update the version number and save the file

Option Explicit

Sub FileVerTest()
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Apr 2021
Dim vVer As Variant
Dim sName As String
Dim sVersion As String
    sName = ActiveDocument.Name
    sVersion = Trim(Split(sName, "(")(0))
    vVer = Split(sVersion, Chr(32))
    sVersion = onlyDigits(CStr(vVer(UBound(vVer))))
    MsgBox sVersion
End Sub

Sub SaveNewVersion_Word()
'PURPOSE: Save file, if already exists add a new version indicator to filename
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Apr 2021

Dim sPath As String
Dim sName As String, sNewName As String
Dim sExt As String
Dim sVer As String
Dim vVer As Variant
Dim sDate As String
Dim sInitials As String

    sInitials = Application.UserInitials
    sDate = Format(Date, "MM.DD.YY")
    sPath = ActiveDocument.path
    If sPath = "" Then GoTo NotSavedYet
    sPath = sPath & "\"
    sName = ActiveDocument.Name
    sExt = Right(sName, Len(sName) - InStrRev(sName, ".") + 1)
    sNewName = Trim(Split(sName, "(")(0))
    sVer = sNewName
    vVer = Split(sVer, Chr(32))
    sVer = onlyDigits(CStr(vVer(UBound(vVer))))
    sName = Replace(sNewName, sVer, Format(sVer + 1, "00"))
    'MsgBox sName & " (" & sInitials & Chr(32) & sDate & ")" & sExt
    ActiveDocument.SaveAs2 sPath & sName & " (" & sInitials & Chr(32) & sDate & ")" & sExt
    'New version saved
    MsgBox "New file version saved (" & Format(sVer + 1, "00") & ")"
lbl_Exit:
    Exit Sub
    'Error Handler
NotSavedYet:
    MsgBox "This file has not been initially saved. " & _
           "Cannot save a new version!", vbCritical, "Not Saved To Computer"    '
    GoTo lbl_Exit
End Sub

Private Function onlyDigits(s As String) As String
'https://stackoverflow.com/questions/7239328/how-to-find-numbers-from-a-string#7239408
'modified by Graham Mayor - https://www.gmayor.com - Last updated - 04 Apr 2021
' Variables needed (remember to use "option explicit").   '
Dim retval As String    ' This is the return string.      '
Dim i As Integer        ' Counter for character position. '

' Initialise return string to empty                       '
    retval = ""

    ' For every character in input string, copy digits to     '
    '   return string.                                        '
    For i = 1 To Len(s)
        If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Or Mid(s, i, 1) = "." Then
            retval = retval + Mid(s, i, 1)
        End If
    Next

    ' Then return the return string.                          '
    onlyDigits = retval
End Function

[tanko]

Welp, you've done it. I've tweaked the code a bit (see below) to open a Save As dialog and to adjust the filename depending on whether there is a space between the version number and the open parenthesis.

Sub SaveNewVersion_Word()
'PURPOSE: Save file, if already exists add a new version indicator to filename
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Apr 2021

Dim sPath As String
Dim sName As String, sNewName As String
Dim sExt As String
Dim sVer As String
Dim vVer As Variant
Dim sDate As String
Dim sInitials As String
Dim newFileName As String

    sInitials = "DSR"
    sPath = ActiveDocument.Path
    If sPath = "" Then GoTo NotSavedYet
    sPath = sPath & "\"
    sDate = Format(Date, "MM.DD.YY")    ' This would be replaced when I get my date format check to work.
    sName = ActiveDocument.Name
    sExt = Right(sName, Len(sName) - InStrRev(sName, ".") + 1)
    sNewName = Trim(Split(sName, "(")(0))
    sVer = sNewName
    vVer = Split(sVer, Chr(32))
    sVer = onlyDigits(CStr(vVer(UBound(vVer))))
    sName = Replace(sNewName, sVer, Format(sVer + 1, "00"))
    'MsgBox sName & " (" & sInitials & Chr(32) & sDate & ")" & sExt

' Below code should find dates formatted with and without periods, but does not work that way.
' If InStrRev(ActiveDocument.Name, ".*)") > 0 Then
'   sDate = Format(Date, "MM.DD.YY")
' Else
'    sDate = Format(Date, "MMDDYY")
' End If

    
If InStrRev(ActiveDocument.Name, " (") > 0 Then
    newFileName = sName & " (" & sInitials & Chr(32) & sDate & ")"
Else
    newFileName = sName & "(" & sInitials & Chr(32) & sDate & ")"
End If

With Application.Dialogs(wdDialogFileSaveAs)
    .Name = newFileName
    .Show
End With

lbl_Exit:
    Exit Sub
    'Error Handler
NotSavedYet:
    MsgBox "This file has not been initially saved. " & _
           "Cannot save a new version!", vbCritical, "Not Saved To Computer"    '
    GoTo lbl_Exit
End Sub

One thing I would like to change is to set it such that it will also test whether the date contains periods. I tried including an If/Then, but it does not work, again apparently because of my InStrRev problem. How do I get InStrRev to use wildcards like Find? I would think that this code should return 07 where the filename is "Master Agreement 07 (JPM 04.03.21)"

Mid(sName, InStrRev(sName, "[0-9] & [0-9]", 2))

By the same token, wouldn't this return ".21)"?

Mid(sName, InStrRev(sName, ".*)", 4))

[gmayor]

The function I gave you gets the version number?

Use the following function to get the date format from the filename (sName)

Private Function DateFormat(sName As String) As String
©Graham Mayor - https://www.gmayor.com - Last updated - 04 Apr 2021 
Dim sDate As String
    If InStr(1, sName, "(") > 0 Then
        sDate = Split(sName, "(")(1)
        sDate = Split(sDate, " ")(1)
        sDate = Split(sDate, ")")(0)
        If InStr(1, sDate, ".") > 0 Then
            DateFormat = "mm.dd.yy" 'note lower case!
        Else
            DateFormat = "mmddyy"
        End If
    Else
        DateFormat = "mm.dd.yy"
    End If
End Function

Call it from a modified version of the original macro

Sub SaveNewVersion_Word()
'PURPOSE: Save file, if already exists add a new version indicator to filename
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Apr 2021

Dim sPath As String
Dim sName As String, sNewName As String
Dim sExt As String
Dim sVer As String
Dim vVer As Variant
Dim sDate As String
Dim sInitials As String
Dim sFormat As String

    sInitials = Application.UserInitials
    sPath = ActiveDocument.path
    If sPath = "" Then GoTo NotSavedYet
    sPath = sPath & "\"
    sName = ActiveDocument.Name
    sFormat = DateFormat(sName)
    sDate = Format(Date, sFormat) 'Format the date
    sExt = Right(sName, Len(sName) - InStrRev(sName, ".") + 1)
    sNewName = Trim(Split(sName, "(")(0))
    sVer = sNewName
    vVer = Split(sVer, Chr(32))
    sVer = onlyDigits(CStr(vVer(UBound(vVer))))
    sName = Replace(sNewName, sVer, Format(sVer + 1, "00"))
    'MsgBox sName & " (" & sInitials & Chr(32) & sDate & ")" & sExt
    ActiveDocument.SaveAs2 sPath & sName & " (" & sInitials & Chr(32) & sDate & ")" & sExt
    'New version saved
    MsgBox "New file version saved (" & Format(sVer + 1, "00") & ")"
lbl_Exit:
    Exit Sub
    'Error Handler
NotSavedYet:
    MsgBox "This file has not been initially saved. " & _
           "Cannot save a new version!", vbCritical, "Not Saved To Computer"    '
    GoTo lbl_Exit
End Sub

[tanko]

After a bunch of tinkering, I think I've finally got it the way I want it. It was malfunctioning when the filename had a parenthetical such as "Master Agreement (Borrower) 02 (JPM 040521)" and I also had to work out a way to tell it to learn how my company does incremental versions (e.g. "Master Agreement (Borrower) 02.2 (JPM 040521)"). But now I think it's working for most scenarios I need! It's probably clunkier than it has to be, but I'm OK with it.

Thanks so much for your help! I'll drop a tip on your website.

Sub SaveNewVersion_Word()
'PURPOSE: Save file, if already exists add a new version indicator to filename
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Apr 2021

Dim sPath As String
Dim sName As String, sNewName As String
Dim sExt As String
Dim sVer As String
Dim vVer As Variant
Dim sDate As String
Dim sInitials As String
Dim newFileName As String
Dim sFormat As String
Dim verIncremental As Boolean
Dim lenAfterDot As Long
Dim verAfterDot As String

    sInitials = "DSR"
    sPath = ActiveDocument.Path
    If sPath = "" Then GoTo NotSavedYet
    sPath = sPath & "\"
    sName = ActiveDocument.Name
    sFormat = DateFormat(sName)
    sDate = Format(Date, sFormat) 'Format the date
    sExt = Right(sName, Len(sName) - InStrRev(sName, ".") + 1)
    sNewName = Trim(Left(sName, InStrRev(sName, "(") - 1))
    sVer = sNewName
    vVer = Split(sVer, Chr(32))
    sVer = onlyDigits(CStr(vVer(UBound(vVer))))

' Find number of digits after "." and find incremental version number, and set verIncremental
If InStrRev(sVer, ".") >= 1 Then
    verIncremental = True
    verAfterDot = Mid(sVer, InStr(1, sVer, ".") + 1)
Else
    verIncremental = False
End If
    
' Upversion document, defaulted to whether current doc is incremental or not
If verIncremental = True Then
    sNewName = Replace(sNewName, "." & verAfterDot, "." & verAfterDot + 1)
Else
    sNewName = Replace(sNewName, sVer, Format(sVer + 1, "00"))
End If

' Name and save doc using existing spacing and quirks
If InStrRev(ActiveDocument.Name, " (") > 0 Then
    newFileName = sNewName & " (" & sInitials & Chr(32) & sDate & ")"
Else
    newFileName = sNewName & "(" & sInitials & Chr(32) & sDate & ")"
End If

With Application.Dialogs(wdDialogFileSaveAs)
    .Name = ActiveDocument.Path & "\" & newFileName
    .Show
End With

lbl_Exit:
    Exit Sub
    'Error Handler
NotSavedYet:
    MsgBox "This file has not been initially saved. " & _
           "Cannot save a new version!", vbCritical, "Not Saved To Computer"    '
    GoTo lbl_Exit

End Sub

Private Function onlyDigits(s As String) As String
'https://stackoverflow.com/questions/7239328/how-to-find-numbers-from-a-string#7239408
'modified by Graham Mayor - https://www.gmayor.com - Last updated - 04 Apr 2021
' Variables needed (remember to use "option explicit").   '
Dim retval As String    ' This is the return string for the version number.      '
Dim i As Integer        ' Counter for character position. '

' Initialise return string to empty                       '
    retval = ""

    ' For every character in input string, copy digits to     '
    '   return string.                                        '
    For i = 1 To Len(s)
        If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Or Mid(s, i, 1) = "." Then
            retval = retval + Mid(s, i, 1)
        End If
    Next

    ' Then return the return string.                          '
    onlyDigits = retval
       
    
End Function

Private Function DateFormat(sName As String) As String
' ©Graham Mayor - https://www.gmayor.com - Last updated - 04 Apr 2021
Dim sDate As String
sDate = Right(sName, Len(sName) - InStrRev(sName, "(") + 1)
    If InStr(1, sDate, "(") > 0 Then
        sDate = Split(sDate, "(")(1)
        sDate = Split(sDate, " ")(1)
        sDate = Split(sDate, ")")(0)
        If InStr(1, sDate, ".") > 0 Then
            DateFormat = "mm.dd.yy" 'note lower case!
        Else
            DateFormat = "mmddyy"
        End If
    Else
        DateFormat = "mm.dd.yy"
    End If
End Function