Ordner erstellen - jeder Tag des Jahres - Monatsweise!

Am Anfang des Jahres immer wieder gefragt: "Wie kann ich für jeden Tag des Jahres einen Ordner erstellen - das Ganze Monatsweise?" Im folgenden zwei Beispiele. Im zweiten Beispiel wird noch ein Vorlagentabellenblatt als extra Exceldatei gespeichert und in jeden Ordner kopiert. Beim erstellen von Ordnern würde ich persönlich nie mit "MKDIR" rumeiern. Wesentlich besser ist es mit der API-Funktion "MakeSureDirectoryPathExists" zu arbeiten.

Ordner erstellen - jeder Tag des Jahres - Monatsweise...[ZIP, 60 KB]

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Public Sub Jahr_Tag_Ordner()
    Dim intMonat As Integer
    Dim intTag As Integer
    Dim strPath As String
    On Error GoTo Fin
    strPath = "C:\Temp\"  ' anpassen!!!! 
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    For intMonat = 1 To 12
        MakeSureDirectoryPathExists strPath & _
            Format(DateSerial(Year(Now), intMonat, 1), _
            "MMMM_YYYY") & "\"
        For intTag = 1 To DateSerial(Year(Now), intMonat + 1, 1) _
            - DateSerial(Year(Now), intMonat, 1)
            MakeSureDirectoryPathExists strPath & _
                Format(DateSerial(Year(Now), intMonat, 1), _
                "MMMM_YYYY") & "\" & _
                Format(DateSerial(Year(Now), intMonat, intTag), _
                "DD_MMMM_DDDD") & "\"
        Next intTag
    Next intMonat
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Public Sub Jahr_Tag_Ordner_Datei()
    Dim intMonat As Integer
    Dim intTag As Integer
    Dim strPath As String
    On Error GoTo Fin
    Application.ScreenUpdating = False
    strPath = "C:\Temp\"  ' anpassen!!!! 
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    With Tabelle2
        .Copy
    If Val(Application.Version) > 11 Then
        ActiveWorkbook.SaveAs strPath & .Name, 56
    Else
        ActiveWorkbook.SaveAs Filename:=strPath & _
            .Name & ".xls"
    End If
        ActiveWorkbook.Close False
    End With
    For intMonat = 1 To 12
        MakeSureDirectoryPathExists strPath & _
            Format(DateSerial(Year(Now), intMonat, 1), _
            "MMMM_YYYY") & "\"
        For intTag = 1 To DateSerial(Year(Now), intMonat + 1, 1) _
            - DateSerial(Year(Now), intMonat, 1)
            MakeSureDirectoryPathExists strPath & _
                Format(DateSerial(Year(Now), intMonat, 1), _
                "MMMM_YYYY") & "\" & _
                Format(DateSerial(Year(Now), intMonat, intTag), _
                "DD_MMMM_DDDD") & "\"
            FileCopy strPath & Tabelle2.Name & ".xls", _
            strPath & _
                Format(DateSerial(Year(Now), intMonat, 1), _
                "MMMM_YYYY") & "\" & _
                Format(DateSerial(Year(Now), intMonat, intTag), _
                "DD_MMMM_DDDD") & "\" & Tabelle2.Name & ".xls"
        Next intTag
    Next intMonat
Fin:
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub