Option Explicit
#Const Develop = False
Sub Example_FolderCreate()
Dim Data, Index, This
Dim i As Long
Dim Folder As String
Data = Range("A2").CurrentRegion.Value
ReDim Index(1 To UBound(Data, 2))
ReDim This(0 To UBound(Data, 2))
This(0) = ThisWorkbook.Path
For i = 1 To UBound(Data, 2)
Index(i) = 1
Next
Do
For i = 1 To UBound(Data, 2)
This(i) = Data(Index(i), i)
Next
Folder = Join(This, "\")
#If Develop Then
Debug.Print Folder
#Else
If Not FolderCreate(Folder) Then
MsgBox Folder, vbCritical, "Can not create:"
Exit Sub
End If
#End If
i = UBound(Data, 2)
Do
If Index(i) = UBound(Data) Then
EndRow:
Index(i) = 1
i = i - 1
If i < 1 Then Exit Sub
Else
Index(i) = Index(i) + 1
If IsEmpty(Data(Index(i), i)) Then
GoTo EndRow
Else
Exit Do
End If
End If
Loop
Loop
End Sub
Function FolderCreate(ByVal Path As String) As Boolean
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
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 & "\"
For Each R In Range("E2", Range("E" & Rows.Count).End(xlUp))
FolderCreate Folder & R
Next
End Sub