VBA to autosave

S

stin25

New Member
Joined
Jun 29, 2009
Messages
10
I have Excel 2003 so I cannot set it to autosave. I need Excel to save every 24 hours (file never closes) and I need it to save with the current date. I have the saving with a current date part, now I just need it to auto save

Here is the code for saving the file name as the current date
Code: 
Sub Folder()
Dim strpath As String, strFileName As String
strpath = "C:\Documents and Settings\leaxl49\Desktop"
strFileName = Format(Now(), "yyyy-mm-dd") & "_" & ActiveWorkbook.Name
ActiveWorkbook.SaveAs Filename:= _
strpath & strFileName, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
End Sub

Thank you
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Sort by date Sort by votes
Hi,
The code below should get you started. But just as a side note, I wanted to make sure you were aware that Excel 2003 saves auto-recover information every 10 minutes by default. You can adjust these settings in Tools>Options>Save

Code: 
Private Sub Workbook_Open()
    AutoSave 'Start Autosaving
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim dtTime As Date
    'Cancel next save-call.
    dtTime = GetSetting("MyAppName", "AutoSave", "SaveNext")
    Excel.Application.OnTime dtTime, "ThisWorkbook.AutoSave", Schedule:=False
End Sub

Private Sub AutoSave()
    Const lngFileNotFound_c As Long = 0&
    Dim strFileName As String
    Dim dtTime As Date
    'Create file name.
    strFileName = Environ("USERPROFILE") & "\Desktop\" & Format$(Now, _
        "yyyy-mm-dd") & "_" & ActiveWorkbook.Name
    If Right$(LCase$(strFileName), 4) <> ".xls" Then
        'Unsaved files won't have an ext yet.
        strFileName = strFileName & ".xls"
    End If
    'If it's already been saved today, then don't oversave:
    If LenB(Dir(strFileName)) = lngFileNotFound_c Then
        ThisWorkbook.SaveCopyAs strFileName
    End If
    dtTime = DateAdd("d", 1, Now) 'Get next save-time
    'This will be used later to cancel:
    SaveSetting "MyAppName", "AutoSave", "SaveNext", dtTime
    'Schedule next save:
    Excel.Application.OnTime dtTime, "ThisWorkbook.AutoSave"
End Sub
 
Last edited:
Upvote 0
Thanks Im pretty sure that is what I'm looking for. Im going to let it run over night and make sure it saves ect. Thanks again.
 
Upvote 0
Might make a less painful test if you try it with a shorter time increment;)
 
Upvote 0
Hi,

This is exactly what I have been trying to figure out for months. Man I wish I knew what you guys knew....

Wondering if I could get some help getting this to save every 5 mins or so, overwritting the last backup,

Backup location is C:backup/excel files/


Thanks again.

Adam
 
Upvote 0
adamsash said:
Man I wish I knew what you guys knew....
Click to expand...
Stick around this board long enough and you will:)
adamsash said:
Wondering if I could get some help getting this to save every 5 mins or so, overwritting the last backup,
Backup location is C:backup/excel files/
Click to expand...
Changing the path is just a matter of putting a new path in. SaveCopyAs automatically overwrites. So if that behavior is desired you just need to remove the check. Then you update the time interval in the DateAdd function. (See Below)
Code: 
Option Explicit

Private Sub Workbook_Open()
    AutoSave 'Start Autosaving
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim dtTime As Date
    'Cancel next save-call.
    dtTime = GetSetting("MyAppName", "AutoSave", "SaveNext")
    Excel.Application.OnTime dtTime, "ThisWorkbook.AutoSave", Schedule:=False
End Sub

Private Sub AutoSave()
    Const lngFileNotFound_c As Long = 0&
    Dim strFileName As String
    Dim dtTime As Date
    'Create file name.
    strFileName = "C:\backup\excel files\" & Format$(Now, _
        "yyyy-mm-dd") & "_" & ActiveWorkbook.Name
    If Right$(LCase$(strFileName), 4) <> ".xls" Then
        'Unsaved files won't have an ext yet.
        strFileName = strFileName & ".xls"
    End If
    'If it's already been saved today, then don't oversave:
    'If LenB(Dir(strFileName)) = lngFileNotFound_c Then
        'Above lines remarked out to allow overwriting.
        ThisWorkbook.SaveCopyAs strFileName
    'End If
    'Set Time interval to 5 minutes:
    dtTime = DateAdd("n", 5, Now) 'Get next save-time
    'This will be used later to cancel:
    SaveSetting "MyAppName", "AutoSave", "SaveNext", dtTime
    'Schedule next save:
    Excel.Application.OnTime dtTime, "ThisWorkbook.AutoSave"
End Sub
 
Upvote 0
Oorang said:
Stick around this board long enough and you will:)

Changing the path is just a matter of putting a new path in. SaveCopyAs automatically overwrites. So if that behavior is desired you just need to remove the check. Then you update the time interval in the DateAdd function. (See Below)
Code: 
Option Explicit

Private Sub Workbook_Open()
    AutoSave 'Start Autosaving
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim dtTime As Date
    'Cancel next save-call.
    dtTime = GetSetting("MyAppName", "AutoSave", "SaveNext")
    Excel.Application.OnTime dtTime, "ThisWorkbook.AutoSave", Schedule:=False
End Sub

Private Sub AutoSave()
    Const lngFileNotFound_c As Long = 0&
    Dim strFileName As String
    Dim dtTime As Date
    'Create file name.
    strFileName = "C:\backup\excel files\" & Format$(Now, _
        "yyyy-mm-dd") & "_" & ActiveWorkbook.Name
    If Right$(LCase$(strFileName), 4) <> ".xls" Then
        'Unsaved files won't have an ext yet.
        strFileName = strFileName & ".xls"
    End If
    'If it's already been saved today, then don't oversave:
    'If LenB(Dir(strFileName)) = lngFileNotFound_c Then
        'Above lines remarked out to allow overwriting.
        ThisWorkbook.SaveCopyAs strFileName
    'End If
    'Set Time interval to 5 minutes:
    dtTime = DateAdd("n", 5, Now) 'Get next save-time
    'This will be used later to cancel:
    SaveSetting "MyAppName", "AutoSave", "SaveNext", dtTime
    'Schedule next save:
    Excel.Application.OnTime dtTime, "ThisWorkbook.AutoSave"
End Sub
Click to expand...


I know its been too old this thread but i have just found, and its exactly what i needed.

Is there a way to delete the old file when the new save happens?
and one more question is it possible to add the time with the date?

thank you
 
Upvote 0
To Oorang,

I am responding to and old post that I think is in the area of what I am looking for. I have some code, below, that when the user clicks on the submit button it will auto send the file to a desired recipient. I have them manually save the file now.

After the email is sent is there a way to save the file to a spcified folder automatically with visual basic? And as the file name I would like to use 2 different cells from the file. The first would be a tracking number and the second would be the customer name.

Any help would be appreciated.

Code: 
Private Sub CommandButton1_Click()
If Range("F12").Value = "" Then
MsgBox "Quote # Cell is empty please fill in the required cell."
Application.EnableEvents = False ' so the selection change event isn't called
Range("F12").Select
ActiveSheet.Unprotect "dod"
Range("C12").Interior.ColorIndex = 3
Application.EnableEvents = True
Exit Sub

ElseIf Range("O12").Value = "" Then
MsgBox "Sales Person is empty please fill in the required cell."
Application.EnableEvents = False ' so the selection change event isn't called
Range("O12").Select
ActiveSheet.Unprotect "dod"
Range("K12").Interior.ColorIndex = 3
Application.EnableEvents = True
Exit Sub





End If

With Sheets(1)
             strSubject = "SR# - " & .Range("AB3") & " - " & "Bill To - " & .Range("F16")

End With

Kill "P:\SR.xls"

ChDir _
        "P:\"
    ActiveWorkbook.SaveAs Filename:= _
        "P:\SR.xls" _
        , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    

Set myOlApp = CreateObject("Outlook.Application")
Set mymail = myOlApp.CreateItem(olMailItem)
mymail.Subject = strSubject
mymail.Body = "See the customer info inside the doc. YES WE CAN!"
mymail.Display
mymail.ReadReceiptRequested = False
mymail.attachments.Add "P:\SR.xls"
mymail.to = "slz design d.o.d"
mymail.Send

'DISABLED FUNCTION 

'MsgBox "You have successfully submitted a sample request to SLZ Design D.O.D", vbExclamation, "COMPANY NAME"

iResponse% = MsgBox("Do you want to save this document", vbQuestion + vbYesNo, "COMPANY NAME")

If iResponse% = vbYes Then

fileSaveName = Application.GetSaveAsFilename( _
    fileFilter:="Microsoft Excel Workbook (*.xls), *.xls")
If fileSaveName <> False Then
    MsgBox "Save as " & fileSaveName
    ThisWorkbook.SaveAs fileSaveName
End If

Else
     MsgBox "This sample request will not be saved", vbExclamation, "THARCO"
End If




Application.ScreenUpdating = False




Application.Quit

End Sub

[CODE]
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
Add date to pdf output
Replies
5
Views
116
Joe4
Joe4
S
  • Solved
Saving Excel Workbook to Sharepoint
2
Replies
13
Views
2K
6StringJazzer
6StringJazzer
S
  • Solved
VBA not save extension when run
Replies
4
Views
155
rollis13
rollis13
I
  • Question
Saving as pdf file from another sheet
Replies
1
Views
448
ipbr21054
I
I
  • Question
Create folder & name it using value in worksheet cell
Replies
1
Views
162
ipbr21054
I

Forum statistics

Threads
1,215,640
Messages
6,125,972
Members
449,276
Latest member
surendra75

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top