Selected Answer
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.
- Const TabName must hold the name of the tab in your workbook on which you have the folder names.
- 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.
- 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.
- 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