Make Folder and Sub

[jaime1182]

Hi all

Hope you are all well.

I am a bit stuck with a macro and was hoping someone could help.

I have the following table starting at Column D:

Entity	Project A	Project B	Project C	Project D
Apple	Chair	Table	Cabinet	Rack
Banana	Cupboard	Lamp
Chocolate	Desk	Ottoman	Drawer
Date Plums	Table Lamp

I need to create Folders for the entities and nest the project subfolders within.

I found this code and it works - for the first row.

Sub CreateFolder()

Dim FPath As String, newDir As String
Dim cell As Range, col As Range, rngFolder As Range, rngCol As Range
Dim ws As Worksheet

Set ws = ActiveWorkbook.Sheets("Sheet1")
Set rngFolder = ws.Range("D2", ws.Cells(Rows.Count, "D").End(xlUp))

FPath = "C:\Users\Admin\Dropbox\"
For Each cell In rngFolder
    newDir = FPath & cell & "\"
    MkDir newDir
    Set rngCol = ws.Range("E" & cell.Row, ws.Cells(cell.Row, Columns.Count).End(xlToLeft))
    For Each col In rngCol
        MkDir newDir & col
    Next
Next

End Sub

When I get to the second MkDir, I get Runtime error '75' : Path/File access error.

    For Each col In rngCol
-->        MkDir newDir & col
    Next

I can see that all the subfolders for row 1 is made so I am presuming it's hitting an error getting to row 2.

How do I get it to loop back up and then make the next folder and subfolders?

Much thanks!

 

[DanteAmor]

Try this:

Sub CreateFolder()
  Dim ws As Worksheet
  Dim FPath As String, newDir As String
  Dim cell As Range, col As Range, rngFolder As Range, rngCol As Range
  
  Set ws = ActiveWorkbook.Sheets("Sheet1")
  Set rngFolder = ws.Range("D2", ws.Cells(Rows.Count, "D").End(xlUp))
  
  FPath = "C:\Users\Admin\Dropbox\"
  
  For Each cell In rngFolder
    newDir = FPath & cell.Value & "\"
    If Dir(newDir, vbDirectory) = "" Then
      MkDir newDir
    End If
    Set rngCol = ws.Range("E" & cell.Row, ws.Cells(cell.Row, Columns.Count).End(xlToLeft))
    For Each col In rngCol
      If col.Value <> "" Then
        If Dir(newDir & col.Value, vbDirectory) = "" Then
          MkDir newDir & col.Value
        End If
      End If
    Next
  Next
End Sub

 

[jaime1182]

You are an absolute genius!!!

Much thanks! Now to try and get the copy macro working! Thanks so much! Saved my bacon again!