VBA to save active workbook with new name and, if already exists, add version nr

[Kra]

Hi all,

I am using macro to save active workbook in specific folder. String from input box is inserted in front of original workbook name. Now it works great, but some users started to save same file multiple times and I need to adjust it to create new version instead.

When they save it with "Test" string in input box it goes like:
Test OriginalName.xlsx
Test Test OriginalName.xlsx

but it should create Test OriginalName v2.xlsx instead.

Any ideas how to improve it?

Private Sub CommandButton13_Click()


On Error GoTo Err

    Dim NewName As String
        NewName = InputBox("Insert Number", "Change file's name")
        
    Dim CurrentName As String
        CurrentName = ActiveWorkbook.Name
    
    Dim ws As Workbook
    Set ws = ActiveWorkbook
    
    If ActiveWorkbook.Name Like "Book*" Then
        ws.SaveAs "C:\General\" & NewName
    
    Else
    
    ws.SaveAs "C:\General\" & NewName & " " & CurrentName
    
    End If
    
Err:

Unload Me

End Sub

 

[HaHoBe]

Hi kra,

I wonder why you Unload an UserForm at the end but utilize an Inputbox to get the information for the new part of the name.

Private Sub CommandButton13_Click()

  Dim strNew As String
  Dim strCurrent As String
  Dim ws As Workbook
  Dim lngNr As Long
  Dim strTempName As String
  
  Const cstrExt As String = ".xlsx"
  Const cstrPath As String = "C:\General\"

On Error GoTo Err

  Set ws = ActiveWorkbook
  strNew = InputBox("Insert Number", "Change file's name")
  
  strCurrent = Left(ws.Name, InStr(1, ws.Name, ".") - 1)
  lngNr = 1
  
  If strCurrent Like "Book*" Then
    ws.SaveAs cstrPath & strNew & " " & strCurrent & ".xlsx", FileFormat:=51
  Else
    If InStr(1, strCurrent, strNew) > 0 Then
     strTempName = cstrPath & strCurrent & ".xlsx"
     Do While Len(Dir(strTempName)) > 0
        lngNr = lngNr + 1
        strTempName = cstrPath & strCurrent & " v" & lngNr & ".xlsx"
      Loop
    Else
      strTempName = cstrPath & strNew & " " & strCurrent & ".xlsx"
    End If
    ws.SaveAs strTempName, FileFormat:=51
  End If
  
Err:

  Unload Me

End Sub

Ciao,
Holger

 

[Kra]

Hi kra,

I wonder why you Unload an UserForm at the end but utilize an Inputbox to get the information for the new part of the name.

Private Sub CommandButton13_Click()

  Dim strNew As String
  Dim strCurrent As String
  Dim ws As Workbook
  Dim lngNr As Long
  Dim strTempName As String
 
  Const cstrExt As String = ".xlsx"
  Const cstrPath As String = "C:\General\"

On Error GoTo Err

  Set ws = ActiveWorkbook
  strNew = InputBox("Insert Number", "Change file's name")
 
  strCurrent = Left(ws.Name, InStr(1, ws.Name, ".") - 1)
  lngNr = 1
 
  If strCurrent Like "Book*" Then
    ws.SaveAs cstrPath & strNew & " " & strCurrent & ".xlsx", FileFormat:=51
  Else
    If InStr(1, strCurrent, strNew) > 0 Then
     strTempName = cstrPath & strCurrent & ".xlsx"
     Do While Len(Dir(strTempName)) > 0
        lngNr = lngNr + 1
        strTempName = cstrPath & strCurrent & " v" & lngNr & ".xlsx"
      Loop
    Else
      strTempName = cstrPath & strNew & " " & strCurrent & ".xlsx"
    End If
    ws.SaveAs strTempName, FileFormat:=51
  End If
 
Err:

  Unload Me

End Sub

Ciao,
Holger

Hi Holger,

Thank you!

About Unload me - button is located in user form.

I am running into two issues:

1. Line

strCurrent = Left(ws.Name, InStr(1, ws.Name, ".") - 1)

returns Invalid procedure error when workbook is not saved yet.

2. It creates new versions perfectly when I run macro only once and close workbook.
When I run it more than once without saving and closing workbook it will save it as:

 

[HaHoBe]

Hi kra,

sorry I missed that, There still may be a problem when you have a workbook that has not been saved before: do you want to save it with a name from the user or use a fixed one? And you would need to check if that file already exists. I suggest you have a look at Application.Dialogs(xlDialogSaveAs) or Application.GetSaveAsFilename which do a better job in my view as an InputBox.

Private Sub CommandButton13_Click()

  Dim strNew As String
  Dim strCurrent As String
  Dim ws As Workbook
  Dim lngNr As Long
  Dim strTempName As String
  Dim strNameOnly As String
  
  Const cstrExt As String = ".xlsx"
  Const cstrPath As String = "C:\General\"

On Error GoTo Err

  Set ws = ActiveWorkbook
  
  strNew = InputBox("Insert Number", "Change file's name")
  If StrPtr(strNew) = 0 Then
    Exit Sub
  ElseIf Len(strNew) = 0 Then
    MsgBox "You did not enter a value! Exit procedure", , "no value"
    Exit Sub
  End If
  
  If ws.Path = "" Then
    'workbook has not been saved,
    ws.SaveAs cstrPath & "Book2Save" & cstrExt, FileFormat:=51
  Else
    strCurrent = Left(ws.Name, InStr(1, ws.Name, ".") - 1)
    If InStr(1, strCurrent, " v") > 0 Then
      strNameOnly = Left(strCurrent, InStrRev(strCurrent, " ") - 1)
      lngNr = Mid(strCurrent, InStrRev(strCurrent, " ") + 2)
    Else
      strNameOnly = strCurrent
      lngNr = 1
    End If
    
    If strCurrent Like "Book*" Then
      ws.SaveAs cstrPath & strNew & " " & strCurrent & ".xlsx", FileFormat:=51
    Else
      If InStr(1, strCurrent, strNew) > 0 Then
       strTempName = cstrPath & strNameOnly & ".xlsx"
       Do While Len(Dir(strTempName)) > 0
          lngNr = lngNr + 1
          strTempName = cstrPath & strNameOnly & " v" & lngNr & ".xlsx"
        Loop
      Else
        strTempName = cstrPath & strNew & " " & strNameOnly & ".xlsx"
      End If
      ws.SaveAs strTempName, FileFormat:=51
    End If
  End If
Err:

  Unload Me

End Sub

Holger