Create folder structure from Excel cell values

0

 I would like to create folders and subfolders using VBA.

I have a code that works but i would like for all of the folder names to come from cell values that I put into a spreadsheet.

Here it the code i am useing, I would like the  ( \2019 ) to be taken from a cell value so it is easy to change without haveing to open the code all the time.

   Sub IfNewFolder()

       Dim r As Range

       Dim RootFolder As String

       RootFolder = "R:\Sales\Quotes (Commercial)\" '<<< CHANGE 1

        For Each r In Range("D1") '<<< CHANGE 2

            If Len(r.Text) > 0 Then

            On Error Resume Next

            MkDir RootFolder & "\" & r.Text

            MkDir RootFolder & "\" & r.Text & "\2019"

               On Error GoTo 0

           End If

       Next r

    MsgBox "Folders Created "

     End Sub

Thanks,

Lamar

Answer
Discuss

Answers

0

Please try the code below after setting its parameters, the 3 constants being declared at the top of the first procedure, to match your environment.

  1. Const TabName must hold the name of the tab in your workbook on which you have the folder names.
  2. Const RootName must hold at least the drive, like "R:", but could hold a longer path with basically never changes. Don't bother about trailing path separators. The macro sets them as required.
  3. Const PathCell must hold the cell address where you write the remainder of the path. It could be something like "Test\2019". Together with the RootName the path is created into which all other folders will be placed.
  4. The names of the other folders are listed immediately below the address of PathCell. If PathCell = "D7" the the other names start at D8 and continue until the end of the column (don't write anything below the last folder name).

The program will create anything that is specified and doesn't exist except the drive. It doesn't touch anything specified and already existing. It will crash if a non-existing drive is specified or a specified file or folder name includes forbidden characters.

Instal the code in a standard code module and run only the first procedure.

Option Explicit

Sub IfNewFolder()
    ' 04 Jan 2019

    Const TabName As String = "MakeDir"
    Const RootName As String = "H:\TestFolder"
    Const PathCell As String = "D3"
    ' File names are in the cells below 'PathCell' (until end of column)


    Dim Ws As Worksheet
    Dim Arr As Variant
    Dim Sp() As String, Tmp() As String
    Dim Pn As String                        ' Path name
    Dim Sep As String
    Dim R As Long, C As Long

    On Error Resume Next
    Set Ws = ActiveWorkbook.Worksheets(TabName)
    If Err Then
        MsgBox "Please activate the workbook containing" & vbCr & _
               "Worksheet """ & TabName & """.", vbExclamation, _
               "Invalid workbook"
        Exit Sub
    End If
    Sep = Application.PathSeparator

    On Error GoTo 0
    With Ws
        C = Range(PathCell).Column
        R = .Cells(.Rows.Count, C).End(xlUp).Row
        Arr = .Range(PathCell).Resize(R - Range(PathCell).Row + 1).Value
    End With
    Pn = CumSeptor(RootName, True)          ' the program sets the path separators
    Pn = CumSeptor(Pn & Arr(1, 1))

    Sp = Split(Pn, Sep)                     ' create host folders
    For C = 1 To UBound(Sp) - 1
        Tmp = Sp
        ReDim Preserve Tmp(C)
        If Not FolderExists(Join(Tmp, Sep)) Then MkDir (Join(Tmp, Sep))
    Next C

    For R = 2 To UBound(Arr)
        If Len(Arr(R, 1)) Then
            Sp = Split(Pn & Arr(R, 1), Sep)
            If Not FolderExists(Join(Sp, Sep)) Then MkDir (Join(Sp, Sep))
        End If
    Next R

    MsgBox "Folders Created "
End Sub

' the functions below are "off the shelf",
' suitable for the above application
Private Function CumSeptor(ByVal Fn As String, _
                           Optional CumSep As Boolean = True) As String
    ' SSY 050 ++ 01 Apr 2017
    CumSeptor = WithCharAppended(Fn, Application.PathSeparator, CumSep)
End Function

Private Function WithCharAppended(Txt As String, _
                                  Ch As String, _
                                  Optional CumChar As Boolean = True) As String
    ' SSY 050 ++ 29 Oct 2016

    Dim Fun As String
    Dim L As Long

    Fun = Txt
    Do
        L = Len(Fun)
        If Right(Fun, 1) = Ch Then
            Fun = Left(Fun, L - 1)
        End If
    Loop While Len(Fun) < L

    If CumChar Then Fun = Fun & Ch
    WithCharAppended = Fun
End Function

Private Function FolderExists(Pn As String) As Boolean
    ' SSY 050 ++ 08 May 2017
    ' return Not True if folder Pn doesn't exist

    If Len(Dir(Pn, vbDirectory)) Then
        If GetAttr(Pn) = vbDirectory Then
            FolderExists = True
        End If
    End If
End Function
Discuss

Discussion

Thanks,
but this does not do what I want,  I only want to get the info from two cells. I have cell (D1) as the first folder and (J2) as the second folder that is inside the (D1) Folder and the folder path is "R:\Sales\Quotes (Commercial)\". so the code would make a folder named after what is in cell (D1) and then it would make a folder from the cell (J2) in the folder that was just ceated from cell (D1).

does that make sense?
Lamar Jan 7, '19 at 12:32 pm
It probably does make sense, but so did your original post and the answer turned our wrong. (1) Consider adapting your workbook to the way my code works. It's a very flexible system, it can do the job 100% correctly, and making it less flexible doesn't necessarily imply improvement. (2) Post your workbook and I will adapt the code to how you want to enter the names.
Variatus (rep: 2354) Jan 7, '19 at 7:31 pm
Add to Discussion

Answer the Question

You must create an account to use the forum. Create an Account or Login