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

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...