Change pre defined "Save as" structure

Diggmau$ · Jan 13th 2021

Hi everyone,

I am new to the forum and must admit upfront, that I am only looking for one time help and won't contribute much to the community. I do not know any VBA and am trying to adjust an add-in I am using to my needs. So I hope you appreciate my honesty - and maybe the code will help someone in the future.

Let's assume we have a worksheet called "Example" created by user Jon Doe (JD) am 13th January 2021.

So the add-in has a button, where when you click it, it saves the the workbook as "Example_2021_01_13_v01_JD" in its current location. If you had never saved the workbook before, it will ask you where you want to save it. If you click the button again, it will update the date - if changed - an move to v02..

I am looking to change this format to "210113_Example_v01_JD"

So again - apologies for having such a blunt request, basically looking for someone to rewrite the code for me to copy&paste. I would really appreciate the help!

Best regards,

Diggmau$

Code

Sub SaveAsVersion(Optional control As IRibbonControl)
'****************************************************
'* Saves as new version+1, current date and user
'* Version 1.0
'* 2016-10-31
'****************************************************
Dim currentdate As String
If Not Licensed Then Call MsgBox("Not licensed", 48): Exit Sub
On Error Resume Next
Dim currentPath As String
Dim currentWorkbook As String
Dim myInitials As String
Dim currentVersion As Integer
Dim newVersion As Integer
'Dim currentDate As String
Dim newFilename As String
Dim WrdArray() As String
Dim aCurExtension() As String
Dim curExtension As String
Dim currentyear() As String
Dim pastyear As Integer
Dim counter As Integer, x1 As Integer
currentPath = ActiveWorkbook.Path
currentWorkbook = ActiveWorkbook.Name
myInitials = UCase(UserInitials())
currentdate = Format(Date, "yyyy_mm_dd")
'Target filename: {name}_{date}_{version}_{user}
'currentWorkbook = "Test_2016_10_21_v01_fap"
If ActiveWorkbook.Path = "" Then
newFilename = Application.Application.GetSaveAsFilename(currentPath & "\" & _
currentWorkbook & "_" & _
currentdate & "_v" & Format(newVersion, "0#") & "_" & myInitials & curExtension, _
fileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save Version")
Application.ActiveWorkbook.SaveAs newFilename
'MsgBox prompt:="File not yet saved. Please save first", Buttons:=32
Exit Sub
End If
currentyear() = Split(currentdate, "_")
WrdArray() = Split(currentWorkbook, "_")
aCurExtension() = Split(currentWorkbook, ".")
curExtension = "." & aCurExtension(UBound(aCurExtension))
'Schaue ob im Namen das Jahr vorhanden ist
For counter = 1 To UBound(WrdArray)
If WrdArray(counter) = CStr(Val(currentyear(0)) - 3) Then pastyear = True
If WrdArray(counter) = CStr(Val(currentyear(0)) - 2) Then pastyear = True
If WrdArray(counter) = CStr(Val(currentyear(0)) - 1) Then pastyear = True
If WrdArray(counter) = CStr(Val(currentyear(0)) - 0) Then pastyear = True
Next counter
If Right(WrdArray(0), 4) = CStr(Val(currentyear(0)) - 3) Then pastyear = True
If Right(WrdArray(0), 4) = CStr(Val(currentyear(0)) - 2) Then pastyear = True
If Right(WrdArray(0), 4) = CStr(Val(currentyear(0)) - 1) Then pastyear = True
If Right(WrdArray(0), 4) = CStr(Val(currentyear(0)) - 0) Then pastyear = True
If UBound(WrdArray) = 2 And pastyear Then
newFilename = Left(WrdArray(0), Len(WrdArray(0)) - 5) & "_" & currentdate & "_v01" & "_" & myInitials & curExtension
ElseIf UBound(WrdArray) = 3 And pastyear Then
newFilename = WrdArray(0) & "_" & currentdate & "_v01" & "_" & myInitials & curExtension
ElseIf UBound(WrdArray) = 4 And pastyear Then
If currentdate = WrdArray(1) & "_" & WrdArray(2) & "_" & WrdArray(3) Then
newFilename = WrdArray(0) & "_" & currentdate & "_v01" & "_" & myInitials & curExtension
Else
If Left(WrdArray(3), 1) = "v" Then
'currentVersion = "v" & Format(currentVersion+1, "0#")
currentVersion = Replace(WrdArray(3), "v", "")
Else
currentVersion = 0
End If
newFilename = Left(WrdArray(0), Len(WrdArray(0)) - 5) & " " & currentdate & "_v" & Format(currentVersion + 1, "0#") & "_" & WrdArray(4)
End If
ElseIf UBound(WrdArray) = 4 And pastyear Then
If currentdate = WrdArray(2) & "_" & WrdArray(3) & "_" & WrdArray(4) Then
newFilename = WrdArray(0) & " " & WrdArray(1) & "_" & currentdate & "_v01" & "_" & myInitials & curExtension
Else
If Left(WrdArray(3), 1) = "v" Then
currentVersion = "v" & Format(Replace(WrdArray(3), "v", "") + 1, "0#")
Else
currentVersion = "v01"
End If
newFilename = WrdArray(0) & " " & WrdArray(1) & "_" & currentdate & "_" & currentVersion & "_" & myInitials & curExtension
End If
ElseIf (UBound(WrdArray) <> 5) Or (LCase(Left(WrdArray(4), 1)) <> "v") Then
For counter = 1 To UBound(WrdArray)
If WrdArray(counter) = CStr(Val(currentyear(0)) - 3) Or WrdArray(counter) = CStr(Val(currentyear(0)) - 2) Or _
WrdArray(counter) = CStr(Val(currentyear(0)) - 1) Or WrdArray(counter) = CStr(Val(currentyear(0)) - 0) Then
currentVersion = Replace(WrdArray(counter + 3), "v", "")
newVersion = currentVersion + 1
newFilename = Left(currentWorkbook, InStr(currentWorkbook, "_" & WrdArray(counter)) - 1) & "_" & currentdate & "_v" & Format(newVersion, "0#") & "_" & myInitials & curExtension
End If
Next counter
If newFilename = "" Then
newFilename = Replace(currentWorkbook, ".xlsx", "") & "_" & currentdate & "_v01_" & myInitials & curExtension
End If
Else
'filename ok
'set new version
currentVersion = Replace(WrdArray(4), "v", "")
newVersion = currentVersion + 1
'construct
newFilename = WrdArray(0) & "_" & currentdate & "_v" & Format(newVersion, "0#") & "_" & myInitials & curExtension
End If
ActiveWorkbook.SaveAs currentPath & "\" & newFilename
' Archiv-Ordner anlegen, File verschieben
'On Error GoTo ErrorHandler
'Dim fso As Object
'Set fso = CreateObject("scripting.filesystemobject")
'If Not fso.folderexists(currentPath & "\Archiv") Then fso.createfolder (currentPath & "\Archiv")
'FileCopy currentPath & "\" & currentWorkbook, currentPath & "\Archiv\" & currentWorkbook
'Kill currentPath & "\" & currentWorkbook
ErrorHandler:
'Void
End Sub
Public Function UserInitials() As String
'****************************************************
'* Function: returns current users initials
'****************************************************
Dim vaNames As Variant
Dim sInit As String
Dim lMax As Long
Dim counter As Long
vaNames = Split(UCase(Application.UserName), " ")
lMax = Application.WorksheetFunction.Min(2, UBound(vaNames))
For counter = 0 To lMax
sInit = sInit & Left$(vaNames(counter), 1)
Next counter
UserInitials = LCase(sInit)
End Function
Function fileExists(s_directory As String, s_fileName As String) As Boolean
'****************************************************
'* Function: checks if given file exists
'* Version 1.0
'* 2016-10-31
'****************************************************
Dim obj_fso As Object
Set obj_fso = CreateObject("Scripting.FileSystemObject")
fileExists = obj_fso.fileExists(s_directory & "\" & s_fileName)
End Function

Display More

**royUK** · Jan 14th 2021

This looks like the addin should be licensed. Licensed addins are usually protected

Diggmau$ · Jan 14th 2021

Many thanks for your reply! Well, I can change the code - already tried and got it to save a file in my desired format if it has never been saved before. But it gets tricky for me after that.

Thank you and best regards

Diggmau$

**royUK** · Jan 14th 2021

Are you getting any error messages?

Diggmau$ · Jan 14th 2021

No error messages, but the following happens:

- I create a new unsaved Excel file "Book1"

- I hit the "Save as" button of the Add-in

- Normally a "Save as" dialogue box will open, asking me where I want to save the file and with the following naming suggestion "Book1_2021_01_14_v01_JD"

- I succeeded in changing that to "210114_Book1_v01_JD"

- I hit the "Save as" button of the tool again tomorrow

- Normally it would now automatically save as "Book1_2021_01_15_v02_JD" in the same location

- What happens now after my edit is, that it saves it as "210114_Book1_v01_JD_2021_01_15_v01_JD"

- But I would like it to save as "210115_Book1_v02_JD"

Kind regards

Diggmau$

**royUK** · Jan 14th 2021

You cannot saveas with the same name as an existing file.

Diggmau$ · Jan 14th 2021

I am not trying to do that. In any case the version counter "_v01_" would be updated to +1..so "_v02_"

If the current date is different from the one in the filename, then also the date is updated

**royUK** · Jan 14th 2021

How is the name constructed?

Diggmau$ · Jan 14th 2021

Right now the add-in constructs it as "Book1_yyyy_mm_dd_v##_JD" with ## going +1 everytime the file is saved and JD being the User initials

I'd like it to construct it as "yymmdd_Book1_v##_JD"

Share