Create folder structure from Excel cell values

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