macro to create folder and subfolder structure and add/rename workbook

[jbaich]

Hi all, I've been trying to work off this older post (sorry if this is not the correct way to reference other posts) http://www.mrexcel.com/forum/excel-questions/525842-creating-folders-subfolders-using-macro.html but my VBA vocabulary is pretty limited to what i could reverse learn from recording and then decyphering macros I've created in the past... meaning, if i can't record it, i'm probably not familiar with it...

The goal is this, the worksheet i'm working from can have a variable number of rows. Column A will have values formatted as 2015-11-00001, (row 2) 2015-14-00001, (row 3) 2015-11-00002; etc.

I would like to find a way to create a folder called "2015", with a subfolder for each unique value in the second position (ie, 11 and 14 in the example above), and then a subfolder in each of those for the value in the third position so it would look as follows...

H:\Summaries\2015->

11->​

00001
00002​

14->​

00001

​

I hope that makes sense... there will likely be several hundred subfolders in each of the "11" and "14" subfolders, and probably more than just two at this level as well. I would like this to loop through all the cells in Col A until it gets to the end (last cell with data) and then stop.

In addtion to this, I have a workbook template that i would like to copy into each of the newly created subfolders at the last level of the heirarchy (ie: 00001 level) and save as with the name of the value in cell B (typically an id number like 73537848X) followed with "Summary Template"

so the newley created workbooks and file paths would be...

H:\Summaries\2015\11\00001\273537848X Summary Template.xlsx
H:\Summaries\2015\11\00002\00376382947 Summary Template.xlsx
H:\Summaries\2015\14\00001\R929374839 Summary Template.xlsx

and so on...

It occurs to me now as I am writing this that perhaps i'm doing this in the wrong order... The Summary template workbooks will also have macros that populate information from one of the tabs via vlookup to other tabs... maybe it's better to have a macro create each workbook, run the internal macros on each book and then auto save them, which in turn would create the file structure?

when i attempted to modify the code in the previously mentioned post, i'd used a list of only 3 populated cells, hoping that the result would be 3 new subfolders at the lowest level, but it seemed like it was going to create new workbooks forever. it got up to 34 before i could interrupt it. Not sure why.

One final thought, would it be possible to have the macro check first to see if the folders already exist and skip those that do, so only new values in the list trigger the creation of subfolders and workbooks? It is likely that the list will grow overtime so it would be great if i could just run the macro every time i wanted to update and add folders for recently included rows without duplicating those that were there before.

I guess this probably seems like a pretty big wishlist and i'm sure i will spend most of my free time over the next several days pouring over past threads trying to learn more about how to make this work, but if anyone out there can help me out or give me a boost, i'd really appreciate it!

Thanks,
Joe

 

[jbaich]

ok, so i found this code which works pretty well so long as i split the file number into 3 columns...

Sub CreatePAABFolder()
 Dim xlSheet As Worksheet
 Dim strPath As String
 Dim LastRow As Long
 Dim LastCol As Long
 Dim i As Long, j As Long
 Const RootFolder As String = "H:\Summaries\" 'Change the Root folder here as per the need
     Set xlSheet = ActiveSheet
     With xlSheet
         LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
         LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
         For i = 2 To LastRow
             strPath = RootFolder
             For j = 1 To LastCol
                 If Not .Cells(i, j) = vbNullString Then strPath = strPath & .Cells(i, j) & Chr(92)
             Next j
             CreateFolders strPath
         Next i
     End With
End Sub
Public Function CreateFolders(strPath As String)
 Dim strTempPath As String
 Dim iPath As Long
 Dim vPath As Variant
     vPath = Split(strPath, "\")
     strPath = vPath(0) & "\"
     For iPath = 1 To UBound(vPath)
         strPath = strPath & vPath(iPath) & "\"
         If Not FolderExists(strPath) Then MkDir strPath
     Next iPath
End Function
Public Function FolderExists(ByVal PathName As String) As Boolean
    Dim nAttr As Long
    On Error GoTo NoFolder
    nAttr = GetAttr(PathName)
    If (nAttr And vbDirectory) = vbDirectory Then
       FolderExists = True
    End If
NoFolder:
End Function

however i'm still left with the question of how to automatically copy a version of of the summary template workbook into each file and rename it according to a corresponding cell value... there may be multiple workbooks required for any of the recently created folders, so i'm not sure how to incorporate that... has anyone else out there had to do anything like this before? Maybe i should start this piece of the problem in a new thread?

Thanks joe

 

[NPoorbaugh]

This works.

Function CreateFolderHierarchy(ByVal path As String)

Dim i As Integer


    For i = 17 To Len(path)
        If Mid(path, i, 1) = "\" Then
            If Dir(Left(path, i - 1), vbDirectory) = vbNullString Then MkDir (Left(path, i - 1))
        End If
    Next i


End Function

 

[NPoorbaugh]

I should have adjusted 1 part, apologies. I wrote this for a specific purpose and hardcoded a start int of 17.

Adjusted code is below:

Function CreateFolderHierarchy(ByVal path As String)

Dim i As Integer


    For i = 3 To Len(path)
        If Mid(path, i, 1) = "\" Then
            If Dir(Left(path, i - 1), vbDirectory) = vbNullString Then MkDir (Left(path, i - 1))
        End If
    Next i


End Function