Create a backup of the current workbook

    
	Sub FileBackUp()
	ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & _
	"" & Format(Date, "mm-dd-yy") & " " & _
	ThisWorkbook.name
	End Sub
    
  

Set the current workbook to close itself

This code will close the workbook to close itself. It also prevents an empty Excel shell (that is a blank excel window) from remaining on the screen after closing.

    
	Sub ShutDown()
	Application.DisplayAlerts = False
	If Application.Workbooks.Count > 1 Then
	   ThisWorkbook.Saved = True
	   ThisWorkbook.Close
	Else
    	Application.Quit
	End If
	End Sub
    
  

Activate a 'buried' workbook and save a backup to a required location

This code is particularly useful as part of a solution (example on this site) whereby you are trying to keep a shared server file from accidentally being left open by someone who has gone on their jollies to the Maldives for three weeks, and not thought about closing a shared file. It could be called from a shut-down procedure so as to make a backup copy before the workbook closes. You may have a timer set to close the workbook after a period of inactivity, but dont want to lose someones unsaved work if they have only popped off to make a coffee or something. It will set an inactive workbook as the active workbook and bring it to the front of the desktop. By doing this it avoids the wrong excel file being saved if multiple excel files are open. It will then save a re-named macro free XLSX backup version of itself to a required folder, it will also create the required folder if it does not already exist.

Don't forget that in the code below you will need to change the variables 'Myfoldername' & 'Myfilename' as required.

A word of caution: If you are using this code with a shared server file, in a workplace for example, then you will need to ensure that the save location is one that every user of the workbook will be permitted to write to. For obvious data security reasons corporate IT managers & administrators will not have granted permissions for all users to access all directories, folders or files. Because of this, in the code snippet below we have selected the public folder which currently allows access from any user on the local machine.

    
Sub SaveCopy()

Dim dirstr As String, DateTime As String, SavePath As String
Dim wb As Workbook

'activate & maximise
ThisWorkbook.Activate
ActiveWindow.WindowState = xlMaximized
Set wb = ActiveWorkbook

'save a copy
dirstr = "C:\Users\Public\Myfoldername"
DateTime = Format(CStr(Now), "dd-mm-yyyy" & " " & "hh-mm-ss")
SavePath = dirstr & "\Copy Of Myfilename" & " " & DateTime

If Not DirectoryExist(dirstr) Then
MkDir dirstr
wb.SaveAs Filename:=SavePath & ".XLSX", FileFormat:=51
Else
wb.SaveAs Filename:=SavePath & ".XLSX", FileFormat:=51
End If
End Sub
    
  

This code snippet is a function rather than a sub routine. It is called by the savecopy sub routine above to check whether the save to folder exists or not. It needs to be pasted into the same module either below or above the savecopy subroutine.

    
Function DirectoryExist(sstr As String)
Dim lngAttr As Long
DirectoryExist = False
If Dir(sstr, vbDirectory) <> "" Then
lngAttr = GetAttr(sstr)
If lngAttr And vbDirectory Then _
DirectoryExist = True
End If
End Function

  

Delete old files from a folder

This code will check the contents of a folder for any files within it that are older than a user determined time period (imaxage).

    
Sub DeleteOldFiles()
     
    'Clears out all files over 7 days old from Dir_Path folder.
    Dir_Path = "C:\Users\Public\Myfoldername"
    'Set the number of days
    iMaxAge = 7
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    'Checks if the folder exists
    If oFSO.FolderExists(Dir_Path) Then
        'Looks at each file to check if it is older than 7 days and deletes older files
        For Each oFile In oFSO.GetFolder(Dir_Path).Files
            If DateDiff("d", oFile.DateLastModified, Now) > iMaxAge Then
                oFile.Delete
            End If
        Next
    End If

End Sub