Solved: Creating main folder and sub directories

[rob0923]

Hi,

I am writing a program that will create a directory depending on the company name and create three folders named Word, Excel and PDF.
The script seems the be working correctly. It seems to check for an existing directory and do nothing if it has found one, or create one if one of the directories isn't found.

I have found various examples of creating folders in an excel VBA, but was wondering if there was a way to create a parent directory depending on the value in "B1" and create an array to insert the remaing directories, but not sure if it is worth the code because of how small the code is for MkDir

I was also wondering how to write an error code for this section of code
incase the drive is readonly or the value in B1 is null and want to exit the sub.

Thanks on advance.

Sub Createdir()

'Set Directory for Company
Dim NmComp As Excel.Range
Dim TodayDate As String

TodayDate = Format(Date, "mm.dd.yyyy")
Set NmComp = Worksheets("Sheet1").Range("B1")

If Dir(ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate, vbDirectory) = "" Then
MkDir ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate
End If

If Dir(ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate & "\Word", vbDirectory) = "" Then
MkDir ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate & "\Word"
End If

If Dir(ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate & "\Excel", vbDirectory) = "" Then
MkDir ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate & "\Excel"
End If

If Dir(ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate & "\PDF", vbDirectory) = "" Then
MkDir ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate & "\PDF"
End If
End Sub

[mdmackillop]

Create a separate sub to carry out repearting tasks and pass the parameter to it. An array of Subs is easily created and altered as required.
Apart from the ReadOnly part, try the following.


Sub Createdir()
'Set Directory for Company
Dim NmComp As Range
Dim Pth As String
Dim TodayDate As String
Dim Subs, s

Subs = Array("Word", "Excel", "PDF") '<===== Adjust as required

Set NmComp = Worksheets("Sheet1").Range("B1")
If Not NmComp.Value = "" Then
TodayDate = Format(Date, "mm.dd.yyyy")
Pth = ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate

DoMkDir Pth
For Each s In Subs
DoMkDir Pth & "\" & s
Next
Else
MsgBox "Name not found"
End If
End Sub

Sub DoMkDir(txt As String)
If Dir(txt, vbDirectory) = "" Then
MkDir txt
End If
End Sub

[rbrhodes]

Hi,

Here's a version:


Option Explicit
Sub Createdir()

'Set Directory for Company


Dim NmComp 'Just a value, not a range
Dim msg As Long 'Inform user message
Dim TodayDate As String
Dim TopDirectory As String

'First check if value in B1
If Worksheets("Sheet1").Range("B1") <> "" Then
'Yes
NmComp = Worksheets("Sheet1").Range("B1")
Else
'No value in "B1"
msg = MsgBox("Range ""B1"" was blank. No directories created.", vbExclamation, "Nothing to be done. S.Beckett")
'Bail
Exit Sub
End If

'Get date for Dir string
TodayDate = Format(Date, "mm.dd.yyyy")

'Build top directory string
TopDirectory = ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate

'Check parent. No parent, no kids.
If Dir(TopDirectory, vbDirectory) = "" Then
'Doesn't exist. Create it and all subdirectories
MkDir TopDirectory
MkDir TopDirectory & "\Word"
MkDir TopDirectory & "\Excel"
MkDir TopDirectory & "\PDF"
Else
'Top directory exists. Check SubDirectories
If Dir(TopDirectory & "\Word", vbDirectory) = "" Then
MkDir TopDirectory & "\Word"
End If
If Dir(TopDirectory & "\Excel", vbDirectory) = "" Then
MkDir TopDirectory & "\Excel"
End If
If Dir(TopDirectory & "\PDF", vbDirectory) = "" Then
MkDir TopDirectory & "\PDF"
End If
End If
End Sub

[Bob Phillips]

Sub Createdir()

'Set Directory for Company
Dim NmComp As Excel.Range
Dim TodayDate As String
Dim RootDir As String

TodayDate = Format(Date, "mm.dd.yyyy")
Set NmComp = Worksheets("Sheet1").Range("B1")
RootDir = ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate

On Error Resume Next
MkDir RootDir
MkDir RootDir & "\Word"
MkDir RootDir & "\Excel"
MkDir RootDir & "\PDF"
On Error GoTo 0
End Sub

[mdmackillop]

Add this into XLD's code, otherwise it will create a "wrong" top level folder

If Not NmComp.Value = "" Then

[Bob Phillips]

Add this into XLD's code, otherwise it will create a "wrong" top level folder

If Not NmComp.Value = "" Then



Should have spotted that in yours :)

[rob0923]

Thank you everyone for your input. These are exactly what I was looking for. Not sure where I would be without vba masters like yourselves! :banghead:

Thanks again.. :)