VBA Code Snippet LibraryCheck out our list of code snippets. Lots of useful procedures to cut and paste into your workbooks.

Create a backup of the current workbook

	Sub FileBackUp()
	ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & _
	"" & Format(Date, "mm-dd-yy") & " " & _
	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
	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
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
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
            End If
    End If

End Sub

Contact us we love conversations. let's talk!

Smiling Two Girls