vba Create folder and subfolder

[Pinaceous]

Hi All,

I'm working with a code that crashes to the point where I have to use the task manager to shut down Excel after it has run.

The code creates a folder with sub folders based upon cell designation(s).

For example, on Worksheet(1) Column A Cell A1 its contents creates the main folder with sub folders based on Column B Cells B1:B10 based upon its names.

So this screen shot in running the code would create the Main Folder titled "Folder A" with its sub folders inside of it called "Sub B1" … to ... "Sub B10".

It seems easy enough but I cannot get it straight. Here is the code, that I don't advise running unless you see how it can be corrected.

Sub CreateFolders()

    Dim aCustomers
    Dim aArticles
    Dim i
    Dim j
    Dim sPath

    sPath = "C:\Users\Desktop\"
    With ThisWorkbook.Sheets(1)
        aCustomers = .Range(.Range("A1"), .Range("A1").End(xlDown)).Value
        aArticles = .Range("B1:B10").Value
    End With
    For i = LBound(aCustomers, 1) To UBound(aCustomers, 1)
        For j = LBound(aArticles, 1) To UBound(aArticles, 1)
            SmartCreateFolder sPath & "\" & aCustomers(i, 1) & "\" & aArticles(j, 1)
        Next
    Next

   
End Sub

Sub SmartCreateFolder(sFolder)

    Static oFSO As Object

    If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
    With oFSO
        If Not .FolderExists(sFolder) Then
            SmartCreateFolder .GetParentFolderName(sFolder)
            .CreateFolder sFolder
        End If
    End With

End Sub

Thank you,
pinaceous

 

[HarryS]

Just change the P:\ to whatever drive name you want

" D:\bert\tom\george\ " extends D drive from whatever is there to three folders

D:\bert\tom\whato.bas ' makes the file whato.bas in the file and its parents .. that do not already exist

 

[Prasad K]

Just change the P:\ to whatever drive name you want

" D:\bert\tom\george\ " extends D drive from whatever is there to three folders

D:\bert\tom\whato.bas ' makes the file whato.bas in the file and its parents .. that do not already exist

MakeAllFoldaAndFile "D:\MyExcel\ "

Like this

 

[HarryS]

You got it
MakeAllFoldaAndFile "C:\freds\farm\isgood\hiscowNames.csv" ' add 1 file
MakeAllFoldaAndFile "D:\freds\farm\HasHorses\ " ' folder ;subs only
MakeAllFoldaAndFile "C:\freds\farm\HasRaceHorses\winnings.jpg" ' other sub folders with file
MakeAllFoldaAndFile "D:\freds\Citris\oranges.xls;Lemons.py;Parmelo.bigGF;GrapeFruit.sour.jpg;Limes.jaf" ' many files
MakeAllFoldaAndFile "D:\freds\Citris\LemonadeFruit\Limes\Jobatica.noo ' one file down 4subfolders

It is flexible ... just try it you can delete your trials..

Programs like Powershell automatically create the required folders sub folders and files if output is directed to them

 

[Prasad K]

You got it
MakeAllFoldaAndFile "C:\freds\farm\isgood\hiscowNames.csv" ' add 1 file
MakeAllFoldaAndFile "D:\freds\farm\HasHorses\ " ' folder ;subs only
MakeAllFoldaAndFile "C:\freds\farm\HasRaceHorses\winnings.jpg" ' other sub folders with file
MakeAllFoldaAndFile "D:\freds\Citris\oranges.xls;Lemons.py;Parmelo.bigGF;GrapeFruit.sour.jpg;Limes.jaf" ' many files
MakeAllFoldaAndFile "D:\freds\Citris\LemonadeFruit\Limes\Jobatica.noo ' one file down 4subfolders

It is flexible ... just try it you can delete your trials..

Programs like Powershell automatically create the required folders sub folders and files if output is directed to them

I have tried it & it's never creating a folder and sub folders in given drIve path

 

[Prasad K]

You got it
MakeAllFoldaAndFile "C:\freds\farm\isgood\hiscowNames.csv" ' add 1 file
MakeAllFoldaAndFile "D:\freds\farm\HasHorses\ " ' folder ;subs only
MakeAllFoldaAndFile "C:\freds\farm\HasRaceHorses\winnings.jpg" ' other sub folders with file
MakeAllFoldaAndFile "D:\freds\Citris\oranges.xls;Lemons.py;Parmelo.bigGF;GrapeFruit.sour.jpg;Limes.jaf" ' many files
MakeAllFoldaAndFile "D:\freds\Citris\LemonadeFruit\Limes\Jobatica.noo ' one file down 4subfolders

It is flexible ... just try it you can delete your trials..

Programs like Powershell automatically create the required folders sub folders and files if output is directed to them

See i have applied like this

Option Explicit
' use like
Private Sub CommandButton1_Click()
   
   MakeAllFoldaAndFile "F:\Excel\ "  ' folder ;subs   only
 
End Sub

Sub MakeAllFoldaAndFile(ByVal PS$)
   Dim PathFolder$, PathFile$, SSA$(), SI&, FileNum&, SIF$(), II&
   '  On Error Resume Next
   If PS <> "" Then  ' else do not bother
      SSA = Split(PS, "\")
      PathFolder = SSA(0) ' the drive
      For SI = 1 To UBound(SSA) - 1        ' skip Drive and Filename(s)
         PathFolder = PathFolder & "\" & SSA(SI)
         If Len(PathFolder) > 0 Then
            If Dir(PathFolder, vbDirectory) = "" Then MkDir PathFolder ' not there so build it
         End If
      Next SI
      
      ' Put in blank files if file not there
      
      If Len(SSA(SI)) > 1 Then             ' put one  space  at end  of  path \ for no files to make
         SIF = Split(SSA(SI), ";")
         For II = 0 To UBound(SIF)
            PathFile = PathFolder & "\" & SIF(II) ' si is now Ubound ???
            If Dir(PathFile) = "" Then     ' if not there so build it
               FileNum = FreeFile
               Open PathFile For Output As #FileNum
               Close #FileNum
            End If
         Next II
      End If
   End If
End Sub

 

[Pinaceous]

Hi Guys!

In using the code from Post #2 & #10:

Sub CreateFolders()
  Dim sPath As String, sMain As String, sFolder As String
  Dim i As Long
 
  sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
  sMain = sPath & "\" & Sheets(1).Range("A1").Value
   
  If Dir(sMain) = "" Then
    MkDir sMain
  End If

  For i = 1 To 10
    sFolder = sMain & "\" & Sheets(1).Range("B" & i).Value
    If Dir(sFolder) = "" Then
      MkDir sFolder
    End If
  Next
End Sub

I'm now getting an error on line:

 MkDir sMain

Before the code worked, but now it is not functioning and I've tried it on several different *.xlsm.

The VBA error reads:
Run-time error '75':
Path/File access error

I know my system here has "upgraded" to the 365 and the Cloud Drive, in suspecting the Cloud pathway has something to do with this error but I don't understand it.

Can anyone help??

Thanks,
Pinaceous