VBA Split Path (логическая или сетевая) для создания каждой папки в пути (Excel)

Question

Я ищу решение для создания каждой папки из пути, либо логического пути с буквой диска, либо сетевого пути лучше в формате l oop

strPath = "c:\Parent Folder\Child Folder\Sub Folder\Stuff"
' OR
strPath = "\\serverfolder\Parent Folder\Child Folder\Sub Folder\Stuff"

varSplit = Split(strPath, "\", , vbTextCompare)

'   CreateFolder for each folder in path
CreateFolder(varSplit(0)) ' if valid, C: or identify is it server folder
CreateFolder(varSplit(1)) ' if dosent exist, Parent Folder
CreateFolder(varSplit(2)) ' Child Folder
CreateFolder(varSplit(3)) ' Sub Folder
CreateFolder(varSplit(4)) ' Stuff

' better in loop

Public Function CreateFolder(ByVal Path As String) As String 
   strPath = Path

   ' Check Destination Folder. Create it, if not exist` 
   On Error Resume Next 
   Select Case Dir(strPath, vbDirectory) 
       Case vbNullString 
           MakeDir = Empty 
       Case Else 
           On Error Resume Next 
           VBA.FileSystem.MkDir (strPath) 
           MakeDir = strPath 
   End Select 

End Function

Answer 1

Вместо этого вы можете использовать один путь и создать его с помощью рекурсивной функции:

Это создаст все необходимые папки. (Так что, если у вас есть C:\Users\Akhtar, он создаст MyFolder и subFolder в MyFolder, и т. Д. c.:

Dim myPath as String
myPath = "C:\Users\Akhtar\MyFolder\subFolder\moreFolders\Others\"
myMkDir(myPath)

Public Sub MyMkDir(sPath As String)
'https://www.devhut.net/2011/09/15/vba-create-directory-structurecreate-multiple-directories/
Dim iStart          As Integer
Dim aDirs           As Variant
Dim sCurDir         As String
Dim i               As Integer

If sPath <> "" Then
    aDirs = Split(sPath, "\")
    If Left(sPath, 2) = "\\" Then
        iStart = 3
    Else
        iStart = 1
    End If

    sCurDir = Left(sPath, InStr(iStart, sPath, "\"))

    For i = iStart To UBound(aDirs)
        sCurDir = sCurDir & aDirs(i) & "\"
        If Dir(sCurDir, vbDirectory) = vbNullString Then
            MkDir sCurDir
        End If
    Next i
End If
End Sub