Hallo,

ich habe eine Excel-Datei, die einen VBA-Code enthält, mit dem ich eine Verzeichnisstruktur automatisch erstellen kann. Das funktioniert grds. sehr gut.
Nur weiß ich noch nicht, wie ich es hinbekomme, dass auch die Vererbungen in den Verzeichnissen schon gesetzt werden.

Die Vererbungen sollen wie folgt gesetzt werden (schon bei Erstellung der Verzeichnisstruktur):

ROOT    >> Vererbung deaktiviert
Ebene 1 >> Vererbung aktiviert
Ebene 2 >> Vererbung aktiviert
Ebene 3 >> Vererbung deaktiviert

Hier mein bisheriger VBA-Code aus der Excel-Datei:

Option Explicit

#Const Develop = False

Sub Example_FolderCreate()
  Dim Data, Index, This
  Dim i As Long
  Dim Folder As String

  'Read in all values  
  'Wenn es in Zeile “1“ eine Überschrift gibt, dann hier „A2“ einsetzen!!  
  Data = Range("A2").CurrentRegion.Value  
  'Create a row pointer for each column  
  ReDim Index(1 To UBound(Data, 2))
  'Create an array for the folder items  
  ReDim This(0 To UBound(Data, 2))
  'Main path  
  This(0) = ThisWorkbook.Path
  
  'Initialize  
  For i = 1 To UBound(Data, 2)
    Index(i) = 1
  Next
  
  Do
    'Copy the items into our array  
    For i = 1 To UBound(Data, 2)
      This(i) = Data(Index(i), i)
    Next
    'Create the path  
    Folder = Join(This, "\")  

#If Develop Then
    Debug.Print Folder
#Else
    'Create it on disk  
    If Not FolderCreate(Folder) Then
      MsgBox Folder, vbCritical, "Can not create:"  
      Exit Sub
    End If
#End If

    'Find next item  
    i = UBound(Data, 2)
    Do
      'Last row?  
      If Index(i) = UBound(Data) Then
EndRow:
        'Start this column again from first row  
        Index(i) = 1
        'Go one column left  
        i = i - 1
        'Done?  
        If i < 1 Then Exit Sub
      Else
        'Next row  
        Index(i) = Index(i) + 1
        'Empty?  
        If IsEmpty(Data(Index(i), i)) Then
          'Start over  
          GoTo EndRow
        Else
          'Create this one in the next round  
          Exit Do
        End If
      End If
    Loop
  Loop
End Sub

Function FolderCreate(ByVal Path As String) As Boolean
  'Creates a complete sub directory structure  
  Dim Temp, i As Integer
  On Error GoTo ExitPoint
  If Dir(Path, vbDirectory) = "" Then  
    If Right$(Path, 1) = "\" Then Path = Left$(Path, Len(Path) - 1)  
    If Left$(Path, 2) = "\\" Then  
      i = InStr(3, Path, "\")  
      Temp = Split(Mid$(Path, i + 1), "\")  
      Temp(0) = Left$(Path, i) & Temp(0)
    Else
      Temp = Split(Path, "\")  
    End If
    Path = ""  
    For i = 0 To UBound(Temp)
      Path = Path & Temp(i) & "\"  
      If Dir(Path, vbDirectory) = "" Then MkDir Path  
    Next
  End If
  FolderCreate = True
ExitPoint:
End Function

Function FolderDelete(ByVal Path As String) As Boolean
  'Deletes a complete sub directory structure  
  Dim This As String
  Dim Temp, i As Integer
  On Error GoTo ExitPoint
  If Right$(Path, 1) <> "\" Then Path = Path & "\"  
  This = Path
  Do
    Do
      If Dir(This & "*.*") <> "" Then Kill This & "*.*"  
      Temp = Dir(This, vbDirectory)
      Do While Temp = "." Or Temp = ".."  
        Temp = Dir
      Loop
      If Temp = "" Then  
        Exit Do
      Else
        This = This & Temp & "\"  
      End If
    Loop
    RmDir This
    If This = Path Then
      Exit Do
    Else
      Temp = Split(This, "\")  
      ReDim Preserve Temp(0 To UBound(Temp) - 1)
      Temp(UBound(Temp)) = ""  
      This = Join(Temp, "\")  
    End If
  Loop
  FolderDelete = True
ExitPoint:
End Function

Sub Test()
  Dim Folder As String
  Dim R As Range
  
  Folder = ThisWorkbook.Path
  If Right(Folder, 1) <> "\" Then Folder = Folder & "\"  
'Angeben in welcher Spalte die Verkettung erfolgen soll:  
  For Each R In Range("E2", Range("E" & Rows.Count).End(xlUp))  
    FolderCreate Folder & R
  Next
End Sub

-------------------------------------------------------------------

Ich freue mich auf Eure Hilfe.

Grüße,

Yan