[EXCEL VBA] Code to create workbook backup every 5 days

[EllieMong]

Dear Everyone!

I have written some code, and it works, exactly how I want it to but:
I realise that I have made it both unsofisticated and a little long winded (I am sure I have some extra variables I don't really need in there somewhere!).

Could anyone here look over it for 5 mins and give me any code suggestions or advice? It's the only way we learn is if we are corrected!

Thanks!
Ellie

- Alternatively I can send through the moclup files I have been using to create the code in the first place, if that would give more context.

Dim sPath               As String
Dim sFile               As String
Dim FilesInPath         As String
Dim MyFiles()           As String
Dim FNum                As Variant
Dim myFilename          As String
Dim myDate              As String
Dim FileDate            As String
Dim NewFilename         As String
Sub BackupCheck()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
ThisWorkbook.Activate

'add line to deal with errors
    On Error GoTo Err_Import

'Define filename
    sFile = ThisWorkbook.Name
    Debug.Print sFile
        
'Define the path where we will look for the required files to merge_
'_in this case, it has to be the same folder as the location of this file plus backup
    sPath = ThisWorkbook.Path
    Debug.Print sPath
    
'If Backup folder does not exist, create it.
    If Len(Dir(sPath & "\Backup\", vbDirectory)) = 0 Then
    MkDir sPath & "\Backup\"
    End If
    'Format sFile
    If Right(sPath, 1) <> "\" Then
    sPath = sPath & "\Backup\"
    End If
           
'Define an array which includes all the files of the correct name/type
    
    myFilename = Left(sFile, InStr(sFile, ".") - 1)
    Debug.Print myFilename

    FilesInPath = Dir(sPath & myFilename & "*.xls")
    Debug.Print FilesInPath
    
'IF there are no new files, produce a message box
    If FilesInPath = "" Then
        Dim Answer As String
            Answer = MsgBox("No backups have been made. Would you like to make a new backup?", vbYesNo + vbDefaultButton1 + vbQuestion, "Backup Database")
            If Answer = vbYes Then
                    'Code for No button Press
                    Call SaveBackup
                    MsgBox "Yes."
                    Else
                        If Answer = vbNo Then
                                Exit Sub
                        End If
                    Exit Sub
            End If
    
    End If
    
'
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop
    
' Set various application properties.
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

'Loop until Dir returns an empty string.
'Do While FNum <> ""

        'only check most recent file name
        For FNum = UBound(MyFiles) To UBound(MyFiles)
        
            myDate = Format(Date, "yyyy-mm-dd")
                Debug.Print myDate
            NewFilename = Left(MyFiles(FNum), InStr(MyFiles(FNum), ".") - 1)
                Debug.Print NewFilename
            FileDate = Right(NewFilename, 10)
                    Debug.Print FileDate
                    Debug.Print DateValue(myDate)
                    Debug.Print DateValue(FileDate)
        
                If DateValue(myDate) - DateValue(FileDate) > 5 Then
                        Call SaveBackup
                End If
        Next FNum
 'Loop
        
Err_Import:
    If Err <> 0 Then
        MsgBox Err.Description
        Err.Clear
        Resume Next
    End If
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
        
End Sub

Sub SaveBackup()
Dim myFilename As String
Dim myDate As String

myFilename = Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1)
myDate = Format(Date, "yyyy-mm-dd")

If Len(Dir(ThisWorkbook.Path & "\Backup\", vbDirectory)) = 0 Then
    MkDir ThisWorkbook.Path & "\Backup\"
    Else
    ActiveWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "\Backup\" & myFilename & "-" & Format(Date, "yyyy-mm-dd") & ".xls"
    ActiveWorkbook.Save
End If

MsgBox "Backup is saved."
End Sub

[EllieMong]

moclup was meant to be mockup btw.... :-)

[rich.value]

Old thread but new answer. Use this auto excel data backup macro to backup excel data at a specific location / drive.

or use this code:

Dim MyDate
MyDate = Date
Dim MyTime
MyTime = Time
Dim TestStr As String
TestStr = Format(MyTime, "hh.mm.ss")
Dim Test1Str As String
Test1Str = Format(MyDate, "DD-MM-YYYY")
ActiveWorkbook.SaveCopyAs Filename:="E:\SEO Backup\" & Test1Str & " " & TestStr & " " & ActiveWorkbook.Name
ActiveWorkbook.Save