excel - 基于 Excel 工作表数据创建多级子文件夹(格式为树)

Question

我的工作表中的文件夹名称格式为文件夹树，如下所示:



一个
乙
C
D
乙


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


我正在尝试在 Windows 10 中创建具有相同结构的文件夹，该工作表位于以下位置:

D:\test

例如:
对于单元格 A1 在工作表中将创建一个文件夹:

D:\test\1

对于单元格 E14 在工作表中将创建一个文件夹:

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

很快。 子文件夹的级别没有限制。
我试过这个代码:

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

问题:
此代码在此示例中运行良好，直到第 4 行。之后，在第 5 行，它开始创建嵌套在第 4 行创建的文件夹中的子文件夹。第 6 行也是如此。例如，对于第 6 行，创建的文件夹:

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

代替:

D:\test\1\1_2

等等。
您能否建议对代码进行任何更改以解决此问题？非常感谢任何替代方法。

Answer 1

像这样的东西应该工作:

通过您的数据逐行循环

在每一行循环列，直到找到数据。列号也是树中级别的深度。

检查实际水平(列)是否大于或小于 LastLevel (之前条目的级别):

如果它更大，那么我们只需将当前数据附加到路径

如果小于或相同，则需要删除 n路径中的级别并附加当前数据。

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

结果:

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