VBA to create a folder name with the date for Monday and Friday separated by a hyphen?

[dougmarkham]

Hi Folks,

I have found a great macro which allows you to check for the existence of folders in a file-path matching: Year, Month and Day (i.e., creating the folder if it doesn't exist).

For instance, if the FilePath starts: C:\Temp Time Sheets\
it checks for
C:\Temp Time Sheets\2019\
C:\Temp Time Sheets\2019\11_November\
C:\Temp Time Sheets\2019\11_November\21\
...creating a folder for any missing folders in the above.

Sub DateFolderSave()

Dim strGenericFilePath      As String: strGenericFilePath = "C:\Temp Time Sheets\"
Dim strYear                 As String: strYear = Year(Date) & "\"
Dim strMonth                As String: strMonth = Format(Month(Date), "00") & "_" & MonthName(Month(Date)) & "\"
Dim strDay                  As String: strDay = Day(Date) & "\"
Dim strFileName             As String: strFileName = "Time Sheet"

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
ThisWorkbook.CheckCompatibility = False

' Check for year folder and create if needed
If Len(Dir(strGenericFilePath & strYear, vbDirectory)) = 0 Then
    MkDir strGenericFilePath & strYear
End If

' Check for month folder and create if needed
If Len(Dir(strGenericFilePath & strYear & strMonth, vbDirectory)) = 0 Then
    MkDir strGenericFilePath & strYear & strMonth
End If

' Check for date folder and create if needed
If Len(Dir(strGenericFilePath & strYear & strMonth & strDay, vbDirectory)) = 0 Then
    MkDir strGenericFilePath & strYear & strMonth & strDay
End If

' Save File
ActiveWorkbook.SaveAs fileName:= _
strGenericFilePath & strYear & strMonth & strDay & strFileName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

ThisWorkbook.CheckCompatibility = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic

' Popup Message
MsgBox "File Saved As: " & vbNewLine & strGenericFilePath & strYear & strMonth & strDay & strFileName

End Sub

My aim is for the last folder in the FilePath to be a date-range spanning the current week e.g., for this week: \16.11.2019-22.11.2019\ (i.e., the folder name would contain two parts: 1) the date for Monday and 2) the date for Friday separated by a hyphen or something similar).

So the full FilePath would be C:\Temp Time Sheets\2019\11_November\16.11.2019-22.11.2019\

I know that to populate a cell with the date for a Monday of any given week, I need to input: =TODAY() - WEEKDAY(TODAY(),3)
However, using the following:

Dim strDay                  As String: strDay = TODAY() - Weekday(TODAY(), 3) & "-" & TODAY() - Weekday(TODAY(), 3) + 4 & "\"

...returns the error message: Sub or Function not defined

I replaced the TODAY element with NOW, and got "Run-time error '52: Bad file name or number"

Would anybody be willing to help me modify the code to achieve this aim?

Kind regards,

Doug.

 

[Norie]

Doug

Try replacing TODAY()/NOW() with Date.

Dim strDay As String

strDay = Format(Date - Weekday(Date, 3), "dd.mm.yyyy") & "-" & Format(Date - Weekday(Date, 3) + 4, "dd.mm.yyyy") & "\"

 

[Paul Ked]

Now() does work

strDay = Format(Now() - Weekday(Now(), 3), "DD.MM.YYYY") & "-" & Format(Now() - Weekday(Now(), 3) + 4, "DD.MM.YYYY") & "\"

 

[Norie]

Now() does work

Only if you include Format.

 

[Paul Ked]

Ah! Thanks

 

[dougmarkham]

Doug

Try replacing TODAY()/NOW() with Date.

Dim strDay As String

strDay = Format(Date - Weekday(Date, 3), "dd.mm.yyyy") & "-" & Format(Date - Weekday(Date, 3) + 4, "dd.mm.yyyy") & "\"

Hi Norie,

Thanks for showing me this---thanks for your time!
I too didn't know about using Format, nice to learn something new.

Kind regards,

Doug.

 

[dougmarkham]

Now() does work

strDay = Format(Now() - Weekday(Now(), 3), "DD.MM.YYYY") & "-" & Format(Now() - Weekday(Now(), 3) + 4, "DD.MM.YYYY") & "\"

Hi Paul,

Thanks for this, it works great! I was afraid to use NOW as when used in formulas, it adds a time-stamp. No such issue with this though.
Thanks for your help.

Kind regards,

Doug.

 

[Paul Ked]

You're welcome