Create a folder and sub folder in Excel VBA

Question

I have a pull down menu of companies that is populated by a list on another sheet. Three columns, Company, Job #, and Part Number.

When a job is created I need a fo

Answer 1

Sub MakeAllPath(ByVal PS$)
    Dim PP$
    If PS <> "" Then
        ' chop any end  name
        PP = Left(PS, InStrRev(PS, "\") - 1)
        ' if not there so build it
        If Dir(PP, vbDirectory) = "" Then
            MakeAllPath Left(PP, InStrRev(PS, "\") - 1)
            ' if not back to drive then  build on what is there
            If Right(PP, 1) <> ":" Then MkDir PP
        End If
    End If
End Sub


'Martins loop version above is better than MY recursive version
'so improve to below

Sub MakeAllDir(PathS$)            

  ' format "K:\firstfold\secf\fold3"

  If Dir(PathS) = vbNullString Then     

 ' else do not bother

   Dim LI&, MYPath$, BuildPath$, PathStrArray$()

   PathStrArray = Split(PathS, "\")

      BuildPath = PathStrArray(0) & "\"    '

      If Dir(BuildPath) = vbNullString Then 

' trap problem of no drive :\  path given

         If vbYes = MsgBox(PathStrArray(0) & "< not there for >" & PathS & " try to append to " & CurDir, vbYesNo) Then
            BuildPath = CurDir & "\"
         Else
            Exit Sub
         End If
      End If
      '
      ' loop through required folders
      '
      For LI = 1 To UBound(PathStrArray)
         BuildPath = BuildPath & PathStrArray(LI) & "\"
         If Dir(BuildPath, vbDirectory) = vbNullString Then MkDir BuildPath
      Next LI
   End If 

 ' was already there

End Sub

' use like
'MakeAllDir "K:\bil\joan\Johno"

'MakeAllDir "K:\bil\joan\Fredso"

'MakeAllDir "K:\bil\tom\wattom"

'MakeAllDir "K:\bil\herb\watherb"

'MakeAllDir "K:\bil\herb\Jim"

'MakeAllDir "bil\joan\wat" ' default drive