CODEWITHSUNDEEP
vbaexcel
Dane Cameron
Dane Cameron

Reputation: 423

VBA - Saving multiple copies of a workbook with a specific naming convention

I have code below to save the current workbook and attach today's date to the end of the file name. How would I modify the code so if two copies of the workbook were to be saved on the same day, the first one would save normally as "Workbook Name, Today's Date.xlsm" and the second one would save as "Workbook Name, Today's Date Copy 2.xlsm". Same thing if the workbook were to be saved 3,4,5 times a day they should save as Copy 3,4,5,etc...

Sub Save_Workbook()

Const Path = "H:\Username\Timehseet Test Path\"
Dim FileName As String
Dim Pos As Long

Pos = InStrRev(ActiveWorkbook.Name, ".") - 1
' If there wasn't a ".", then the file doesn't have an extension and Pos = -1

If Dir(Path & Left(ActiveWorkbook.Name, Pos) & Format(Now, "d-mm-yyyy") & Mid(ActiveWorkbook.Name, Pos + 1)) <> "" Then
    ActiveWorkbook.SaveAs FileName:=Path & Left(ActiveWorkbook.Name, Pos) & "copy 2" & Mid(ActiveWorkbook.Name, Pos + 1)
Else
    ActiveWorkbook.SaveAs FileName:=Path & Left(ActiveWorkbook.Name, Pos) & Format(Now, "d-mm-yyyy") & Mid(ActiveWorkbook.Name, Pos + 1)

End If
End Sub

Upvotes: 0

Views: 1540

Answers (3)

Profex
Profex

Reputation: 1390

Listen, you added a comma after the original name, Great! (now use it)

Dim FileName as String, FileExtension as String

FileName = "Workbook Name, Today's Date Copy 2.xlsm"
Pos = InStrRev(FileName, ".") - 1
FileExtension = ".xlsx"    ' <-- Set a default
If Pos > 0 then 
    FileExtension = Mid(FileName, Pos)
    FileName = Left(FileName, Pos)
End if

FileExtension has been pulled out from the FileName, and the Filename doesn't have an extension anymore. Now lets go after the Comma

Pos = InStrRev(FileName, ",")
If Pos2 > 0 then FileName = Left(FileName, Pos2 -1)

That was easy, FileName has now been cleaned of the Date and Copy junk. While you could have looked for the copy before we cleaned it, I think it's easier to just try a few times, since you're going to want to check if the file exists anyway.

You can alternatively just add the time like PhantomLord mentioned.

Dim Try as long
Dim FullName as String

Try = 0     
FullName = Path & FileName & Format(Now, ", d-mm-yyyy") & FileExtension

' Lets put a safety limit to stop the code if something goes wrong
Do While Try < 1000 And Dir(FullName) = vbNullString
    Try = Try + 1
    FullName = Path & FileName & Format(Now, ", d-mm-yyyy") & " Copy " & IIF(Try > 1, Try, vbNullString) & FileExtension
Loop
ActiveWorkbook.SaveAs FileName:=FullName

I even thru in the IIF() for fun!

Upvotes: 1

Phantom Lord
Phantom Lord

Reputation: 700

Instead of appending "Copy xxx", why not to append the time? eg

 "Workbook Name, 2018-04-05 12.30.23.xlsm"

Upvotes: 3

Vityata
Vityata

Reputation: 43585

Well, the question could be changed a bit, to get what you are looking for. In general, you are looking for a function, which splits some strings by dots and spaces and increments the last one with 1.

E.g., if this is your input:

"WorkbookName 12.12.12.xlsm"
"WorkbookName 13.18.22 Copy 230.xlsm"
"WorkbookName 12.11.19 Copy 999.xlsm"

Your function should give the folowing output:

"WorkbookName 12.12.12.xlsm"
"WorkbookName 13.18.231.xlsm"
"WorkbookName 12.11.1000.xlsm"

Once you achieve this, the saving of the workbook could be carried out through that function. This is some function that gets that output:

Sub TestMe()        
    Dim path1 As String: path1 = "WorkbookName 12.12.12.xlsm"
    Dim path2 As String: path2 = "WorkbookName 13.18.22 Copy 230.xlsm"
    Dim path3 As String: path3 = "WorkbookName 12.11.19 Copy 999.xlsm"

    Debug.Print changeName(path1)
    Debug.Print changeName(path2)
    Debug.Print changeName(path3)        
End Sub

Public Function changeName(path As String) As String

    changeName = path

    Dim varArr As Variant
    varArr = Split(path, ".")

    Dim splitNumber As Long
    splitNumber = UBound(varArr)

    Dim preLast As String: preLast = varArr(splitNumber - 1)
    If IsNumeric(preLast) Then Exit Function

    Dim lastWithSpace As String
    lastWithSpace = Split(preLast)(UBound(Split(preLast)))
    Dim incrementSome As String
    incrementSome = Left(preLast, Len(preLast) - Len(lastWithSpace))

    If IsNumeric(lastWithSpace) Then
        preLast = Split(preLast)(UBound(Split(preLast))) + 1
        varArr(splitNumber - 1) = incrementSome & preLast
        changeName = Join(varArr, ".")
    End If

End Function

The changeName function could be a bit sanitized, with some checks, whether UBound-1 exists in order to avoid error.The function splits the input string to array by . symbol and works with the pre-last value received. Then, if the value is numeric, it does nothing, but if the value looks like this 22 Copy 230, it splits once again and increments the last element with one.

At the end it returns the string.

If you need to check the date as well, then one more layer of splits and arrays should be added.

Upvotes: 1

Related Questions