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

 

[DanteAmor]

Try this:

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

 

[Pinaceous]

Wow DanteAmor!

That is a beautiful code!

Now I can add to this one ect.!

Thanks,
pinaceous

PS. How can/would I attach a file to the main folder?

 

[DanteAmor]

PS. How can/would I attach a file to the main folder?

I do not understand what you mean.

 

[Pinaceous]

Posting a picture to hopefully help explain it a bit more, but if I have a pdf file, for example here I have Voynich-Manuscript.pdf, could I assign it to the folder of Sheets(1).Range("A1")?

Assuming that I could let the code know the designation of the file.

Please let me know.

Thank you!
pinaceous

 

[DanteAmor]

I still don't understand what you want to do with this file: "Voynich-Manuscript.pdf".
I guess you want to move or copy it. But that would be a different topic than this thread. I recommend you create a new thread.

 

[Pinaceous]

Okay sorry about that, thank you for your help!

 

[DanteAmor]

Youre welcome.

 

[HarryS]

Option Explicit
' use like
Private Sub CommandButton1_Click()
   MakeAllFoldaAndFile "P:\freds\farm\isgood\hiscowNames.csv" ' add 1 file
   MakeAllFoldaAndFile "P:\freds\farm\HasHorses\ "  ' folder ;subs   only
   MakeAllFoldaAndFile "P:\freds\farm\HasRaceHorses\winnings.jpg" ' other sub folders with file
   MakeAllFoldaAndFile "P:\freds\Citris\oranges.xls;Lemons.py;Parmelo.bigGF;GrapeFruit.sour.jpg;Limes.jaf" ' many files

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

 

[Prasad K]

Try this:

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

your code is awesome i also need like this code to create folder and sub folders & one more small query how to change directory is this code like if i want to create folder in any Drive Like D:\ or E:\