Backup creation upon open

D

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,390
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I want to create a backup of a file once I open it.

  • The backup needs to be done the first time the file is opened each week, but only after a Wednesday, so Wednesday, Thursday or Friday.
  • I only need it once per week and for the backup, just make a copy of the file.
  • The location of the backup files need to be stored in a backup folder that is located in the current directory of the spreadsheet. It then needs to be separated by folders of year and month.
  • The file name for the backup file needs to be "the name of the current file - the date the backup is run", for instance, "Sample_file - dd.mm.yy"
Thanks
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Sort by date Sort by votes
See if this does what you're looking for.
This goes into ThisWorkbook code module
VBA Code: 
Option Explicit

Private Sub Workbook_Open()
MakeArchive
End Sub

Insert a standard Module and paste this code into it

VBA Code: 
Option Explicit



Public Sub MakeArchive()
Dim ans As VbMsgBoxResult, d, yr, mn, dy
d = Weekday(Now, vbSunday)
yr = Year(Now)
mn = Month(Now)
dy = Day(Now)
If d = 4 Or d = 5 Or d = 6 Then
    If CheckForArchive(ThisWorkbook.Path) = False Then
        ans = MsgBox("There is no archive folder. Would you like to create one?", vbYesNo + vbQuestion, _
            "Archive Not Found")
        If ans = vbNo Then Exit Sub
        MkDir (ThisWorkbook.Path & "\Archive")
        MkDir (ThisWorkbook.Path & "\Archive\" & yr)
        MkDir (ThisWorkbook.Path & "\Archive\" & yr & "\" & mn)
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Archive\" & Year(Now) & "\" & Month(Now) & "\" & _
             mn & "-" & dy & ".xlsx"
    End If
    If CheckForRecordYear(ThisWorkbook.Path & "\Archive", yr) = False Then
        MkDir (ThisWorkbook.Path & "\Archive\" & yr)
        MkDir (ThisWorkbook.Path & "\Archive\" & yr & "\" & mn)
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Archive\" & Year(Now) & "\" & Month(Now) & "\" & _
             mn & "-" & dy & ".xlsx"
    End If
    If CheckForRecordMonth(ThisWorkbook.Path & "\Archive\" & yr, mn) = False Then
        MkDir (ThisWorkbook.Path & "\Archive\" & yr & "\" & mn)
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Archive\" & Year(Now) & "\" & Month(Now) & "\" & _
             mn & "-" & dy & ".xlsx"
    End If
    If CheckForRecordDay(ThisWorkbook.Path & "\Archive\" & yr & "\" & mn, dy) = False Then
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Archive\" & Year(Now) & "\" & Month(Now) & "\" & _
             mn & "-" & dy & ".xlsx"
    End If
End If
End Sub
Private Function CheckForArchive(ByVal fPath As String) As Boolean
Dim fObj As Object, fldr As Object, f As Object
Set fObj = CreateObject("Scripting.FileSystemObject")
Set fldr = fObj.GetFolder(fPath)
For Each fldr In fldr.SubFolders
    If fldr.Name = "Archive" Then CheckForArchive = True: Exit Function
Next fldr
CheckForArchive = False
End Function
Private Function CheckForRecordYear(ByVal fPath As String, ByVal yr As Variant) As Boolean
Dim fObj As Object, fldr As Object, f As Object
Set fObj = CreateObject("Scripting.FileSystemObject")
Set fldr = fObj.GetFolder(fPath)
For Each fldr In fldr.SubFolders
    If fldr.Name = CStr(yr) Then CheckForRecordYear = True: Exit Function
Next fldr
CheckForRecordYear = False
End Function
Private Function CheckForRecordMonth(ByVal fPath As String, ByVal mn As Variant) As Boolean
Dim fObj As Object, fldr As Object, f As Object
Set fObj = CreateObject("Scripting.FileSystemObject")
Set fldr = fObj.GetFolder(fPath)
For Each fldr In fldr.SubFolders
    If fldr.Name = CStr(mn) Then CheckForRecordMonth = True: Exit Function
Next fldr
CheckForRecordMonth = False
End Function
Private Function CheckForRecordDay(ByVal fPath As String, ByVal dy As Variant) As Boolean
Dim fObj As Object, fldr As Object, f As Object
Set fObj = CreateObject("Scripting.FileSystemObject")
Set fldr = fObj.GetFolder(fPath)
For Each fldr In fldr.Files
    If fldr.DateCreated < Now() - 6 Then CheckForRecordDay = False: Exit Function
Next fldr
CheckForRecordDay = True
End Function
 
Upvote 0
I found an error. Also, your Workbook will have to be saved as .xlsm Macro Enabled Workbook
EDIT:
VBA Code: 
Option Explicit



Public Sub MakeArchive()
Dim ans As VbMsgBoxResult, d, yr, mn, dy
d = Weekday(Now, vbSunday)
yr = Year(Now)
mn = Month(Now)
dy = Day(Now)
If d = 4 Or d = 5 Or d = 6 Then
    If CheckForArchive(ThisWorkbook.Path) = False Then
        ans = MsgBox("There is no archive folder. Would you like to create one?", vbYesNo + vbQuestion, _
            "Archive Not Found")
        If ans = vbNo Then Exit Sub
        MkDir (ThisWorkbook.Path & "\Archive")
        MkDir (ThisWorkbook.Path & "\Archive\" & yr)
        MkDir (ThisWorkbook.Path & "\Archive\" & yr & "\" & mn)
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Archive\" & Year(Now) & "\" & Month(Now) & "\" & _
             mn & "-" & dy & ".xlsm"
    End If
    If CheckForRecordYear(ThisWorkbook.Path & "\Archive", yr) = False Then
        MkDir (ThisWorkbook.Path & "\Archive\" & yr)
        MkDir (ThisWorkbook.Path & "\Archive\" & yr & "\" & mn)
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Archive\" & Year(Now) & "\" & Month(Now) & "\" & _
             mn & "-" & dy & ".xlsm"
    End If
    If CheckForRecordMonth(ThisWorkbook.Path & "\Archive\" & yr, mn) = False Then
        MkDir (ThisWorkbook.Path & "\Archive\" & yr & "\" & mn)
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Archive\" & Year(Now) & "\" & Month(Now) & "\" & _
             mn & "-" & dy & ".xlsm"
    End If
    If CheckForRecordDay(ThisWorkbook.Path & "\Archive\" & yr & "\" & mn, dy) = False Then
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Archive\" & Year(Now) & "\" & Month(Now) & "\" & _
             mn & "-" & dy & ".xlsm"
    End If
End If
End Sub
Private Function CheckForArchive(ByVal fPath As String) As Boolean
Dim fObj As Object, fldr As Object, f As Object
Set fObj = CreateObject("Scripting.FileSystemObject")
Set fldr = fObj.GetFolder(fPath)
For Each fldr In fldr.SubFolders
    If fldr.Name = "Archive" Then CheckForArchive = True: Exit Function
Next fldr
CheckForArchive = False
End Function
Private Function CheckForRecordYear(ByVal fPath As String, ByVal yr As Variant) As Boolean
Dim fObj As Object, fldr As Object, f As Object
Set fObj = CreateObject("Scripting.FileSystemObject")
Set fldr = fObj.GetFolder(fPath)
For Each fldr In fldr.SubFolders
    If fldr.Name = CStr(yr) Then CheckForRecordYear = True: Exit Function
Next fldr
CheckForRecordYear = False
End Function
Private Function CheckForRecordMonth(ByVal fPath As String, ByVal mn As Variant) As Boolean
Dim fObj As Object, fldr As Object, f As Object
Set fObj = CreateObject("Scripting.FileSystemObject")
Set fldr = fObj.GetFolder(fPath)
For Each fldr In fldr.SubFolders
    If fldr.Name = CStr(mn) Then CheckForRecordMonth = True: Exit Function
Next fldr
CheckForRecordMonth = False
End Function
Private Function CheckForRecordDay(ByVal fPath As String, ByVal dy As Variant) As Boolean
Dim fObj As Object, fldr As Object, f As Object
Set fObj = CreateObject("Scripting.FileSystemObject")
Set fldr = fObj.GetFolder(fPath)
For Each fldr In fldr.Files
    If fldr.DateCreated < Now() - 6 Then CheckForRecordDay = False: Exit Function
Next fldr
CheckForRecordDay = True
End Function
 
Upvote 0
Thanks for the reply. With the above code, I get the error "Path not found" when I open the spreadsheet it highlights the line of code:
VBA Code: 
Set fldr = fObj.GetFolder(fPath)

in Private Function CheckForArchive
 
Upvote 0
Could you step through the code and let me know what the variable fPath is on your machine?
 
Upvote 0
When the error happens, the code halts and the value of fPath is a long web address, I can't see all of it. This may be as it is stored on Microsoft one drive.
 
Upvote 0
Yep. This code will only work with local files, and I don't think MkDir will work with One Drive file locations. You may have to use Office Scripts. Unfortunately, I know nothing about Office Scripts.
 
Upvote 0
Do you mean to save a copy of the file to a local address on your machine? If so,

VBA Code: 
ThisWorkbook.SaveAs "C:\Users\A_User_Name_Here\Documents.xlsm", xlOpenXMLWorkbookMacroEnabled
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
1K
Micron
M
P
  • Question Question
Combining PDF files from a folder using a list from excel (not importing to excel, combining as a single PDF)
Replies
2
Views
341
Patrick Desarzens
P
N
  • Question Question
Always open xlsx files in the already-open instance of Excel
Replies
2
Views
451
nevyoung
N
I
  • Solved
Hyperlink customer in another workbook to a file
2
Replies
11
Views
493
ipbr21054
I
R
  • Solved
Go through subfolders, select matching files and copy a worksheet from each into a master file
2
Replies
17
Views
915
BatTodor
B

Forum statistics

Threads
1,224,521
Messages
6,179,278
Members
452,902
Latest member
Knuddeluff

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