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