Create folders and subfolders from Excel

[wedor]

I need to create a set of folders with subfolders from a list in Excel.

I can find code to create the folders but not with the subfolders.

Any help would be appreciated.

 

[OssieMac]

Sub New_Folder_And_SubFolder()

Dim strNewFolder As String
Dim strSubFolder As String

strNewFolder = "My New Folder"

strSubFolder = "My Sub Folder"

MkDir strNewFolder

MkDir strNewFolder & "\" & strSubFolder


End Sub

 

[wedor]

Here is the code I have used so far to make the original foilders and it
works perfectly,

Option Explicit
Dim intRow, objExcel, objSheet, strPathExcel
Dim strHomeFolder, strHome, strUser
Dim objFSO, objShell, intRunError
Dim objFolder,colFolders

' Note you will have to amend the following variables
strHome = "H:\clients\"
strPathExcel = "H:\cls.xls"
intRow = 2 ' Row 1 contains headings

' Open the Excel spreadsheet
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objExcel = CreateObject("Excel.Application")
Set objSheet = objExcel.Workbooks.Open(strPathExcel)

' Create a shell for cmd and CACLS
Set objShell = CreateObject("Wscript.Shell")

' Here is the loop that cycles through the cells
Do Until (objExcel.Cells(intRow,1).Value) = ""
strUser = objExcel.Cells(intRow, 1).Value
call HomeDir ' I decided to use a subroutine
intRow = intRow + 1
Loop
objExcel.Quit ' Clears up Excel


Sub HomeDir()
strHomeFolder = strHome & strUser
If strHomeFolder <> "" Then
If Not objFSO.FolderExists(strHomeFolder) Then
On Error Resume Next
objFSO.CreateFolder strHomeFolder
If Err.Number <> 0 Then
On Error GoTo 0
Wscript.Echo "Cannot create: " & strHomeFolder
End If
End If
End If
End Sub
objExcel.Quit
WScript.Quit


Where would I insert that code to make this work?

I need a sub set of folders in each of the orginal folders named things like
taxes, payroll, forms, each folder will have the same subfolders.

 

[OssieMac]

I wonder why you are using such a complex method to perform a simple
operation. Are you calling this from another application like Access or
something?

Anyway you could create the sub folders immediately after calling the
HomeDir routine. Simply concatenate the sub folder name with the main folder.

You could create a subroutine similar to HomeDir and pass a parameter to it
for each of the sub folders.

Call MakeSubFolder("Taxes")
Call MakeSubFolder("Payroll")
'Call for each sub folder required.


Sub MakeSubFolder(strSubFolderName as String)

strSubFolder = strHomeFolder & "\" & strSubFolderName

'Insert Code to create as in Homedir to create folder.

 

[wedor]

Mainly because I am not a coder nor do I have much experience with vb.

I just used code I found online and modified it to fit my current needs.

I lack the basic knowledge to insert the code correctly without explicit
instructions so I "punt".


The original list did come from Access, I put it into Excel so that I could
use the first bit of code I found and it did work fine.

I was able to find a second bit of code to perform the other fucntion of
adding the subfolders.

Here are the bits of code from each file, they do exactly what I want
although it would be nice to have this operation cleaned up and put in a
single file.


'create folders
Option Explicit
Dim intRow, objExcel, objSheet, strPathExcel
Dim strHomeFolder, strHome, strUser
Dim objFSO, objShell, intRunError

' Note you will have to amend the following variables
strHome = "H:\clients\"
strPathExcel = "H:\cls.xls"
intRow = 3 ' Row 1 contains headings

' Open the Excel spreadsheet
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objExcel = CreateObject("Excel.Application")
Set objSheet = objExcel.Workbooks.Open(strPathExcel)

' Create a shell for cmd and CACLS
Set objShell = CreateObject("Wscript.Shell")

' Here is the loop that cycles through the cells
Do Until (objExcel.Cells(intRow,1).Value) = ""
strUser = objExcel.Cells(intRow, 1).Value
call HomeDir ' I decided to use a subroutine
intRow = intRow + 1
Loop
objExcel.Quit ' Clears up Excel


Sub HomeDir()
strHomeFolder = strHome & strUser
If strHomeFolder <> "" Then
If Not objFSO.FolderExists(strHomeFolder) Then
On Error Resume Next
objFSO.CreateFolder strHomeFolder
If Err.Number <> 0 Then
On Error GoTo 0
Wscript.Echo "Cannot create: " & strHomeFolder
End If
End If
End If
End Sub
objExcel.Quit

WScript.Quit


'create subfolders
Set fso = CreateObject("Scripting.FileSystemObject")

set root=fso.getFolder("H:\clients")

call folderAdd(root)

sub folderAdd(grp)

on error resume next

grp.subFolders.add("Billing")

grp.subFolders.add("Correspondence")

grp.subFolders.add("Accounting")

grp.subFolders.add("Tax")

grp.subFolders.add("Payroll")

err.clear

for each fldr in grp.subFolders

set nf=fso.GetFolder(fldr.path)

if nf.name<>"Tax" and nf.name<>"Payroll" and nf.name<>"Billing" and
nf.name<>"Correspondence" and nf.name<>"Accounting" then call folderAdd(nf)

set nf=nothing

next

end sub


I don't dispute your stated opinion that this is probably more complex than
need be but it is all I've got at the moment.

If you would be able to show me a bit that would be cleaner and easier I
would be happy to use it.