Создание папки и подпапок с названиями и числами месяцев

Option Explicit
 
#If Win64 Then
    #If VBA7 Then    ' Windows x64, Office 2010
        Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As LongLong
    #Else    ' Windows x64,Office 2003-2007
        Public Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
    #End If
#Else
    #If VBA7 Then    ' Windows x86, Office 2010
        Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
    #Else    ' Windows x86, Office 2003-2007
        Public Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
    #End If
#End If
 
Sub tt()
    Dim i&, s$
 
    s = ThisWorkbook.Path & "" & Year(Now) & "" & Format(MonthName(Month(Date)), "mmmm") & ""
 
    For i = 1 To Day(DateValue("01." & Month(Now) + 1 & "." & Year(Now)) - 1)
        MakeSureDirectoryPathExists s & i & ""
    Next
 
    ThisWorkbook.Close 0
End Sub

Private Sub Test()
    Dim i&, s$
 
    s = ThisWorkbook.Path & "\" & Format(Now, "YYYY\\MMMM\\")
    For i = 1 To Day(DateSerial(Year(Now), Month(Now) + 1, 0))
        MakeSureDirectoryPathExists s & i & "\"
    Next
End Sub

Private Sub Test2()
    Dim i As Date
 
    For i = DateSerial(Year(Now), Month(Now), 1) To DateSerial(Year(Now), Month(Now) + 1, 0)
        MakeSureDirectoryPathExists ThisWorkbook.Path & Format(i, "\\YYYY\\MMMM\\D\\")
    Next
End Sub