Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Boolean



Private Sub Workbook_BeforeClose(Cancel As Boolean)

Dim fso As Object, strToFolder As String

    strToFolder = "D:\" & Format(Date, "ddd") & "-" & Format(Date, "dd-mm-yyyy") & "\"

    MakeSureDirectoryPathExists strToFolder

    Set fso = CreateObject("Scripting.FileSystemObject")

    fso.copyfile Source:=ThisWorkbook.FullName, Destination:=strToFolder, OverwriteFiles:=True

End Sub