Erstellen einer Ordnerhierachie

Sub MakeFolders() Dim rng As Range Dim Path As String Dim maxRows, maxCols, r, c As Integer Path = "C:\Test" Set rng = Range("A2:b500") maxRows = rng.Rows.Count maxCols = rng.Columns.Count For c = 1 To maxCols r = 1 Do While r

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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) + 1, intMonat, 1), _ "MMMM_YYYY") & "\" For intTag = 1 To DateSerial(Year(Now) + 1, intMonat + 1, 1) _ - DateSerial(Year(Now) + 1, intMonat, 1) MakeSureDirectoryPathExists strPath & _ Format(DateSerial(Year(Now) + 1, intMonat, 1), _ "MMMM_YYYY") & "\" & _ Format(DateSerial(Year(Now) + 1, intMonat, intTag), _ "DD_MMMM_DDDD") & "\" Next intTag Next intMonat Fin: If Err.Number 0 Then MsgBox "Fehler: " & _ Err.Number & " " & Err.Description End Sub

Ich habe noch etwas gesucht und eine perfekte Lösung gefunden. Zwar verstehe ich viele Teile nicht, aber es funktioniert. In den Spalten A, B, C habe ich nun in A durchgehend das Jahr, in B die Monate und in C die Tage.
Vielleicht hilft es auch noch anderen:
Option Explicit

Sub startCreating()
Call CreateDirectory(2, 1)
End Sub

Sub CreateDirectory(ByVal row As Long, ByVal col As Long, Optional ByRef path As String)
If (Len(ActiveSheet.Cells(row, col).Value)


Function thanks to: http://www. _
vbaexpress.com/kb/getarticle.php?kb_id=559

Function FileOrDirExists(PathName As String) As Boolean
'Macro Purpose: 

Function returns TRUE if the specified file
'               or folder exists, false if not.
'PathName     : Supports Windows mapped drives or UNC
'             : Supports Macintosh paths
'File usage   : Provide full file path and extension
'Folder usage : Provide full folder path
'               Accepts with/without trailing "\" (Windows)
'               Accepts with/without trailing ":" (Macintosh)
Dim iTemp As Integer
'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)
'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select
'Resume error checking
On Error GoTo 0
End Function

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread