VBA Code that will save the current workbook multiple times

[Craig_Moore]

Hi I hope someone can help me

I currently have to copy and paste a master copy of a workbook every day and rename it to the current date I.E 01.01.20 but I am after a button I can press that will automatically save the workbook 356 / 366 times naming all the workbooks a different date is this possible

thanks

 

[pjmorris]

try this:

Sub MultiSave()
    Dim sFilename As Variant
    Dim sName As String
    Dim sExtension As String
    
    Dim dDate As Date
    Dim nLeapYear As Integer
    Dim n As Integer 'date counter
    
    sFilename = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xlsx; *.xlsm), *.xlsx; *.xlsm")
    
    If sFilename <> "" Then
        sName = Left(sFilename, InStr(sFilename, ".") - 1)
        sExtension = Right(sFilename, Len(sFilename) - Len(sName))
        
        dDate = DateValue("1 Jan 2020")
        If MsgBox("Is this a leapyear?", vbYesNo) = vbYes Then
            nLeapYear = 1
        Else
            nLeapYear = 0
        End If
        
        For n = 1 To 364 + nLeapYear
            sFilename = sName & " - " & Format(dDate, "dd-mmm-YYyy") & sExtension
            ActiveWorkbook.SaveAs Filename:=sFilename
            dDate = dDate + n
        Next n
    End If
End Sub

 

[Craig_Moore]

Hi pjmorris
thank-you for the quick response i have tried the above and it partiality works it saves the files but dose not save a file fore every day it seems to jump i.e 01-01-20, 03-01-20, 16-01-20
also when running the code it doesn't end until i force it to stop

any further help would be greatly received

thanks

Craig

 

[pjmorris]

HI Craig,

Many thanks for the screen shot - it has helped me understand the problem. Thankfully the cure is simple, just change:

dDate = dDate + n

to

dDate = dDate + 1

It might seem that the code doesn't end, but I suspect it is just a much slower process than expected. I've added a line to the code below which updates the status bar at the bottom of the excel window which shows what date is being exported. That should give you a clear indication of how its going. It includes the correction above.

Sub MultiSave()
    Dim sFilename As Variant
    Dim sName As String
    Dim sExtension As String
   
    Dim dDate As Date
    Dim nLeapYear As Integer
    Dim n As Integer 'date counter
   
    sFilename = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xlsx; *.xlsm), *.xlsx; *.xlsm")
   
    If sFilename <> "" Then
        sName = Left(sFilename, InStr(sFilename, ".") - 1)
        sExtension = Right(sFilename, Len(sFilename) - Len(sName))
       
        dDate = DateValue("1 Jan 2020")
        If MsgBox("Is this a leapyear?", vbYesNo) = vbYes Then
            nLeapYear = 1
        Else
            nLeapYear = 0
        End If
       
        For n = 1 To 364 + nLeapYear
            sFilename = sName & " - " & Format(dDate, "dd-mmm-YYyy") & sExtension
            Application.StatusBar = "Exporting File Dated: " & dDate
           
            ActiveWorkbook.SaveAs Filename:=sFilename
            dDate = dDate + 1
           
        Next n
    End If
End Sub

HTH

 

[Craig_Moore]

hi pjmorris

thankyou so much for this, this code has worked perfectly


Craig

 

[pjmorris]

Excellent, many thanks for the feedback and delighted to have been able to help.