none
Creating folders and Sub folders RRS feed

  • Question

  • Hey All

    I have the below code to create folders from a range of cells but I need to expand it to include subfolders too.

    The structure I need is

    Level 1 Level 2 Level 3
    Name Attendance Warnings
        Casu
        Late
        OHS
        Other
        RTW
        Special Leave
      Coaching  
      Disciplinary  
      Other  
      Plans  
    Dim Rng As Range
    Dim maxRows, maxCols, r, c As Integer
    Set Rng = Selection
    maxRows = Rng.Rows.Count
    maxCols = Rng.Columns.Count
    For c = 1 To maxCols
    r = 1
    Do While r <= maxRows
    If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
    MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
    On Error Resume Next
    End If
    r = r + 1
    Loop
    Next c
    End Sub
    
    

    Appreciate the help as always

    Tuesday, July 11, 2017 2:30 PM

Answers

  • The code works perfectly in creating the nested folder but for my reuirments there are a couple of issues. The first being that the 3rd level (with casu, late etc) only needs to sit in the attendance folder, not the others.

    I also have a list of approx. 300 names to cycle through and this only creates the first name

    Where is the problem? ;-)

    The first step is to split the cells into 2 regions, to keep it very simple and clearly, I've created a sheet named "Folders":

    The next step is to parametrize my Sub Main from above, this sub uses Range("A1").CurrentRegion by default.

    But now we want to "feed" the sub with the Range object from the outside and I've renamed it:

    Sub CreateFolderFromRegion(ByVal Where As Range)
      Dim Data, Index, This
      Dim i As Long
      Dim Folder As String
    
      'Read in all values
      Data = Where.Value
    
    'the rest of the sub is identical


    For a short test execute this sub:

    Sub Test()
      CreateFolderFromRegion Range("A1").CurrentRegion
      CreateFolderFromRegion Range("A10").CurrentRegion
    End Sub

    Now I assume that you have another sheet with the names from A1 to A...wherever, so we can create a simple FOR EACH loop, write the current name into sheet Folders... and let it run.

    Any questions?

    Andreas.

    Sub Main()
      Dim ThisName As Range
      
      For Each ThisName In Range("A1", Range("A" & Rows.Count).End(xlUp))
        With Sheets("Folders")
          .Range("A1") = ThisName
          .Range("A10") = ThisName
          CreateFolderFromRegion .Range("A1").CurrentRegion
          CreateFolderFromRegion .Range("A10").CurrentRegion
        End With
      Next
    End Sub

    Monday, July 17, 2017 3:07 PM

All replies

  • - Make a new file
    - Copy this into the sheet:

    Name Attendance Warnings
    Coaching Casu
    Disciplinary Late
    Other OHS
    Plans Other
    RTW
    Special Leave

    - Open the VBA editor
    - Add a regular module
    - Paste in the code below
    - Save the file to disk
    - Run sub Main and look into the immediate window
    - If you are satisfied with the output set Develop = False

    Andreas.

    Option Explicit
    
    #Const Develop = True
    
    Sub Main()
      Dim Data, Index, This
      Dim i As Long
      Dim Folder As String
    
      'Read in all values
      Data = Range("A1").CurrentRegion.Value
      'Create an row pointer for each column
      ReDim Index(1 To UBound(Data, 2))
      'Create an array for the folder items
      ReDim This(0 To UBound(Data, 2))
      'Main path
      This(0) = ThisWorkbook.Path
      
      'Initialize
      For i = 1 To UBound(Data, 2)
        Index(i) = 1
      Next
      
      Do
        'Copy the items into our array
        For i = 1 To UBound(Data, 2)
          This(i) = Data(Index(i), i)
        Next
        'Create the path
        Folder = Join(This, "\")
    
    #If Develop Then
        Debug.Print Folder
    #Else
        'Create it on disk
        If Not FolderCreate(Folder) Then
          MsgBox Folder, vbCritical, "Can not create:"
          Exit Sub
        End If
    #End If
    
        'Find next item
        i = UBound(Data, 2)
        Do
          'Last row?
          If Index(i) = UBound(Data) Then
            'Start this column again from first row
            Index(i) = 1
            'Go one column left
            i = i - 1
            'Done?
            If i < 1 Then Exit Sub
          Else
            'Next row
            Index(i) = Index(i) + 1
            'Empty?
            If Not IsEmpty(Data(Index(i), i)) Then Exit Do
          End If
        Loop
      Loop
    End Sub
    
    Private Function FolderCreate(ByVal Path As String) As Boolean
      'Creates a complete sub directory structure
      Dim Temp, i As Integer
      On Error GoTo ExitPoint
      If Dir(Path, vbDirectory) = "" Then
        If Right$(Path, 1) = "\" Then Path = Left$(Path, Len(Path) - 1)
        If Left$(Path, 2) = "\\" Then
          i = InStr(3, Path, "\")
          Temp = Split(Mid$(Path, i + 1), "\")
          Temp(0) = Left$(Path, i) & Temp(0)
        Else
          Temp = Split(Path, "\")
        End If
        Path = ""
        For i = 0 To UBound(Temp)
          Path = Path & Temp(i) & "\"
          If Dir(Path, vbDirectory) = "" Then MkDir Path
        Next
      End If
      FolderCreate = True
    ExitPoint:
    End Function
    

    Tuesday, July 11, 2017 8:24 PM
  • Hello,

    If your issue has been resolved, i suggest you share your solution here or mark helpful post as answer to close the thread.

    If your issue presists and the code shared by Andreas doesnt work for you, please feel free to let us know.

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, July 14, 2017 7:23 AM
    Moderator
  • Hey Andreas

    The code works perfectly in creating the nested folder but for my reuirments there are a couple of issues. The first being that the 3rd level (with casu, late etc) only needs to sit in the attendance folder, not the others.

    I also have a list of approx. 300 names to cycle through and this only creates the first name

    Appreciate your help in this :)

    Monday, July 17, 2017 10:46 AM
  • The code works perfectly in creating the nested folder but for my reuirments there are a couple of issues. The first being that the 3rd level (with casu, late etc) only needs to sit in the attendance folder, not the others.

    I also have a list of approx. 300 names to cycle through and this only creates the first name

    Where is the problem? ;-)

    The first step is to split the cells into 2 regions, to keep it very simple and clearly, I've created a sheet named "Folders":

    The next step is to parametrize my Sub Main from above, this sub uses Range("A1").CurrentRegion by default.

    But now we want to "feed" the sub with the Range object from the outside and I've renamed it:

    Sub CreateFolderFromRegion(ByVal Where As Range)
      Dim Data, Index, This
      Dim i As Long
      Dim Folder As String
    
      'Read in all values
      Data = Where.Value
    
    'the rest of the sub is identical


    For a short test execute this sub:

    Sub Test()
      CreateFolderFromRegion Range("A1").CurrentRegion
      CreateFolderFromRegion Range("A10").CurrentRegion
    End Sub

    Now I assume that you have another sheet with the names from A1 to A...wherever, so we can create a simple FOR EACH loop, write the current name into sheet Folders... and let it run.

    Any questions?

    Andreas.

    Sub Main()
      Dim ThisName As Range
      
      For Each ThisName In Range("A1", Range("A" & Rows.Count).End(xlUp))
        With Sheets("Folders")
          .Range("A1") = ThisName
          .Range("A10") = ThisName
          CreateFolderFromRegion .Range("A1").CurrentRegion
          CreateFolderFromRegion .Range("A10").CurrentRegion
        End With
      Next
    End Sub

    Monday, July 17, 2017 3:07 PM
  • Sorry Andreas for the delay in marking - this is perfect -thank you so much.
    Wednesday, August 9, 2017 11:59 AM