Create Multi Level Subfolders Based on Excel Worksheet Data (Formatted as Tree)

user_14792779 0
Viewed 103

I have folder names in my worksheet formatted as folder tree like this:

A B C D E
1 1
2 1_1
3 1_1_1
4 1_1_2
5 1_2
6 1_3
7 2
8 3
9 3_1
10 3_1_1
11 3_1_1_1
12 3_1_1_2
13 3_1_1_2_1
14 3_1_1_2_2

I am trying to create folders in windows 10 with the same structure in this worksheet in location:

D:\test

For example: For cell A1 in the worksheet a folder will be created:

D:\test\1

For cell E14 in the worksheet a folder will be created:

D:\test\3\3_1\3_1_1\3_1_1_2\3_1_1_2_2

So on. There is no limit of levels of subfolders.

I have tried this code:

Sub CreateMultiLevelFolders()

Const RootPath = "D:\test7"

Dim FolderPath As String
Dim RW, LastColmInRow As Integer

On Error Resume Next


For RW = 1 To ActiveSheet.UsedRange.Rows.Count

            LastColmInRow = Range("XFD" & RW).End(xlToLeft).Column
                              
                If LastColmInRow = 1 Then
                        FolderPath = RootPath & "\" & Cells(RW, LastColmInRow).Value
                        MkDir FolderPath
                        ChDir FolderPath
                        
                        Else
                        FolderPath = FolderPath & "\" & Cells(RW, LastColmInRow).Value
                End If
                MkDir FolderPath
                ChDir FolderPath
                
    If Err.Number <> 0 Then
    Err.Clear
    End If

Next

End Sub

The problem: This code worked fine till row 4 in this example. After that, in row 5, it started creating subfolders nested into the folder created in row 4. Same for row 6. For example, for row 6, the folder created:

D:\test\1\1_1\1_1_2_\1_2

instead of:

D:\test\1\1_2

And so on.

Could you please suggest any change in the code to correct this problem? Any alternative approach is much appreciated.

vba excel
1 Answers

Something like that should work:

  • Loop row wise through your data
  • In each row loop column wise until data is found. The column number is also the depth of the level in the tree.
  • Check if the actual level (column) is greater or less than the LastLevel (level of the entry before):
    • If it is greater then we just append the current data to the path
    • If it is less or the same then we need to remove n levels from the path and append the current data.
Option Explicit

Public Sub CreateMultiLevelFolders()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Dim TreeData As Variant
    TreeData = ws.UsedRange.Value
    
    Dim LastLevel As Long
    
    Dim Path As String
    Path = "D:\test"    'init root path
    
    Dim iRow As Long
    For iRow = LBound(TreeData, 1) To UBound(TreeData, 1)
        Dim iCol As Long
        For iCol = LBound(TreeData, 2) To UBound(TreeData, 2)
            If TreeData(iRow, iCol) <> vbNullString Then
                If LastLevel < iCol Then 'go level deeper
                    LastLevel = iCol
                    Path = Path & "\" & TreeData(iRow, iCol)
                    
                    Debug.Print Path
                    Exit For
                Else 'go level up
                    Dim iLevel As Long 'remove n levels where n = LastLevel - iCol + 1
                    For iLevel = iCol To LastLevel
                        Path = Left$(Path, InStrRev(Path, "\") - 1)
                    Next iLevel
                    
                    LastLevel = iCol
                    Path = Path & "\" & TreeData(iRow, iCol)
                    
                    Debug.Print Path
                    Exit For
                End If
            End If
        Next iCol
    Next iRow
End Sub

Result:

D:\test\1
D:\test\1\1_1
D:\test\1\1_1\1_1_1
D:\test\1\1_1\1_1_2
D:\test\1\1_2
D:\test\1\1_3
D:\test\2
D:\test\3
D:\test\3\3_1
D:\test\3\3_1\3_1_1
D:\test\3\3_1\3_1_1\3_1_1_1
D:\test\3\3_1\3_1_1\3_1_1_2
D:\test\3\3_1\3_1_1\3_1_1_2\3_1_1_2_1
D:\test\3\3_1\3_1_1\3_1_1_2\3_1_1_2_2
user_32196130
Related