Solved: VBA to Save a workbook with an incrementing Version Number

[JimS]

Any ideas on how to do a Save of an Excel Workbook where it would automatically save the Workbook with a version number in the Workbook Name that would increment by 1 if the same version number already existed in the folder.

In example, VBA is set up to save the workbook as “Box Shipments_UPS_07052009-v1.xls” but a v1 already exists in the folder, could it automatically save the Workbook as a v2.
The Name is a combination of 2 different fields within the Workbook with todays date and the version number.
Box Shipments is one field and UPS is another field and today’s date followed by the version number (ie: v1, v2, v3, v4 and so on) in my example above.

The original Workbook is a Template that gets updated periodically and its original name has no resemblance to the name that the resulting Workbook needs to be named.
Thanks…
Jim

[mdmackillop]

You may need to tweak this a little to suit your file naming etc.

Option Explicit
Sub Increment()
Dim pth As String
pth = "C:\AAA\"
ActiveWorkbook.SaveAs pth & FCount(pth, ActiveWorkbook.Name)
End Sub

Function FCount(pth As String, fname As String)
fname = Split(fname, "-v")(0)
With Application.FileSearch
.NewSearch
.LookIn = pth
.Filename = fname
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
FCount = fname & "-v" & .FoundFiles.Count + 1
End If
End With
End Function

[JimS]

mdmackillop,

Thanks for your response...

Is there a way that the pth = "C:\AAA\" does not have to be hard-coded?

Can it be set-up so that it can "capture" the path after I navigate to a particular folder and then run?

Jim

[mdmackillop]

Use

pth = BrowseForFolder

and add this function to the module

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'''Code from kpuls, www.VBAExpress.com..portion (http://www.vbaexpress.com..portion/) of Knowledge base submission
Dim ShellApp As Object
Dim Drv As String
Dim fs As Object, d As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, Range("A1").Value)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
MsgBox "No folder selected", vbInformation
BrowseForFolder = False
End Function

[JimS]

I think it would be better to hard code the Folder and let it increment the version number.

Can this be made to work?

It doesn't like the FCount in the "fname =" line


Sub Increment()
Dim pth As String
fname1 = Range("Cust").Value
fname2 = Range("ServCntA").Value

fname = fname1 & "_" & fname2 & "Posts" & "_" & Format(Date, "mmddyyyy") & "-v" & FCount & ".xls" <<<<< This line fails >>>>>


Const pth As String = "C:\Data\!My Docs\My VCE-VSCE Reports\"

ActiveWorkbook.SaveAs pth & "\" & FCount(pth, ActiveWorkbook.Name)


End Sub

Function FCount(pth As String, fname As String)

fname = Split(fname, "-v")(0)
With Application.FileSearch
.NewSearch
.LookIn = pth
.FileName = fname
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
FCount = fname & "-v" & .FoundFiles.Count + 1
End If
End With
End Function

[mdmackillop]

There are a lot of values in that line. Can you post the whole of your code?

[JimS]

That's all the code for the SaveAs Routine.

Basically the SaveAs Name is made up of the values of 2 Cell Ranges and the Date with a version number, that needs to increment every time it saves (if the same version already exists in the folder).

An example of the SaveAs Name would be "Rocker_15Posts_08162009-v1"

Jim

[mdmackillop]

Option Explicit
Sub Increment()
Dim pth As String
Dim fName1 As String, fName2 As String, fName As String
pth = BrowseForFolder
fName1 = Range("Cust").Value
fName2 = Range("ServCntA").Value
fName = fName1 & "_" & fName2 & "Posts" & "_" & Format(Date, "mmddyyyy") & "-v"
ActiveWorkbook.SaveAs pth & FCount(pth, fName)
End Sub

Function FCount(pth As String, fName As String)
fName = Split(fName, "-v")(0)
With Application.FileSearch
.NewSearch
.LookIn = pth
.Filename = fName
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
FCount = fName & "-v" & .FoundFiles.Count + 1
End If
End With
End Function

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'''Code from kpuls, www.VBAExpress.com..portion (http://www.vbaexpress.com..portion/) of Knowledge base submission
Dim ShellApp As Object
Dim Drv As String
Dim fs As Object, d As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, Range("A1").Value)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
MsgBox "No folder selected", vbInformation
BrowseForFolder = False
End Function

[GTO]

Greetings to all,

I wasn't quite sure if we were currently looking for a constant pathway or not, but had followed along.

@mdmackillop:

Hi Malcom :-)

Say - I was thinking that in Increment()

pth = BrowseForFolder
'//Add//
If Not Right(pth, 1) = "\" Then pth = pth & "\"


...as at least I am experiencing BrowseFolder not returning the trailing seperator.

And in FCount()

' If .Execute() > 0 Then
' FCount = fName & "-v" & .FoundFiles.Count + 1
' End If
'// Assign a string to FCount regardless, which should start at "v1" on //
'// a new day or if the file is saveas'd to a different folder. //
.Execute
FCount = fName & "-v" & .FoundFiles.Count + 1


I tested several times, so hopefully my observations aren't goofed.

A great day to all,

Mark

[JimS]

Thanks to both...

This now works as I wanted it to...

Thanks again...