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