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.
Code: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




Reply With Quote
