Option ExplicitSub CreateNestedFolders()    Dim selectedRange As Range    Dim rootPath As String    Dim fullPath As String    Dim r As Range    Dim cell As Range    Dim fd As FileDialog    Dim foldersCreated As Long    Dim foldersExisted As Long    Dim summaryMsg As String    Dim statusText As String    Dim statusCell As Range    ' 1. 让用户选择包含文件夹结构的工作表区域    On Error Resume Next    Set selectedRange = Application.InputBox( _        Prompt:="请选择包含文件夹结构的单元格区域:", _        Title:="选择单元格区域", _        Type:=8)    On Error GoTo 0    If selectedRange Is Nothing Then        MsgBox "没有选择单元格区域. 操作取消.", vbExclamation        Exit Sub    End If    ' 2. 让用户选择创建文件夹的根目录    Set fd = Application.FileDialog(msoFileDialogFolderPicker)    fd.Title = "选择想要创建文件夹所在的位置"    If fd.Show = -1 Then        rootPath = fd.SelectedItems(1)    Else        MsgBox "没有选择目录位置. 操作取消.", vbExclamation        Exit Sub    End If    ' 确保根目录以反斜杠结尾    If Right(rootPath, 1) <> "\" Then rootPath = rootPath & "\"    ' 优化：关闭屏幕刷新，提高运行速度    Application.ScreenUpdating = False    Application.Calculation = xlCalculationManual    ' 3. 遍历选中的每一行数据    foldersCreated = 0    foldersExisted = 0    For Each r In selectedRange.Rows        fullPath = rootPath        Dim hasContent As Boolean        hasContent = False        ' 拼接完整路径：根目录 + 每个非空单元格内容        For Each cell In r.Cells            If Trim(cell.Value) <> "" Then                fullPath = fullPath & Trim(cell.Value) & "\"                hasContent = True            End If        Next cell        ' 删除末尾多余的反斜杠        If Right(fullPath, 1) = "\" Then            fullPath = Left(fullPath, Len(fullPath) - 1)        End If        ' 设置状态单元格位置：当前行的右侧第一列        Set statusCell = r.Offset(0, r.Columns.Count).Cells(1, 1)        ' 4. 检查路径有效性并创建，同时记录状态        If Not hasContent Then            statusText = "无内容"        ElseIf fullPath = rootPath Then            statusText = "路径为空"        Else            If Dir(fullPath, vbDirectory) <> "" Then                ' 文件夹已存在                foldersExisted = foldersExisted + 1                statusText = "已存在"            Else                ' 尝试创建                If CreatePathRecursive(fullPath) Then                    foldersCreated = foldersCreated + 1                    statusText = "创建成功"                Else                    statusText = "失败 (非法字符)"                End If            End If        End If        ' 将状态写入单元格右侧        statusCell.Value = statusText        ' 可选：根据状态给文字上色 (如果需要上色，取消下面几行的注释)        With statusCell             Select Case statusText                 Case "创建成功": .Font.Color = vbGreen                 Case "已存在": .Font.Color = vbBlue                 Case "失败 (非法字符)": .Font.Color = vbRed             End Select         End With    Next r    ' 恢复系统设置    Application.ScreenUpdating = True    Application.Calculation = xlCalculationAutomatic    ' 自动调整列宽以适应状态文字    selectedRange.Offset(0, selectedRange.Columns.Count).Columns.AutoFit    ' 5. 显示操作结果摘要    summaryMsg = "操作完成！" & vbCrLf & vbCrLf    summaryMsg = summaryMsg & foldersCreated & " 个文件夹成功创建." & vbCrLf    If foldersExisted > 0 Then        summaryMsg = summaryMsg & foldersExisted & " 个文件夹已存在." & vbCrLf    End If    summaryMsg = summaryMsg & "结果已显示在选中区域的右侧列。" & vbCrLf & vbCrLf & "位置: " & rootPath    MsgBox summaryMsg, vbInformationEnd Sub' 递归创建文件夹路径的函数' 返回 True 表示成功或已存在，False 表示出错Function CreatePathRecursive(ByVal fullPath As String) As Boolean    Dim parts() As String    Dim currentPath As String    Dim i As Long    On Error GoTo ErrorHandler    ' 按反斜杠拆分路径    parts = Split(fullPath, "\")    ' 从驱动器盘符开始构建 (例如 "C:")    currentPath = parts(0)    ' 遍历路径的每一部分并逐级创建文件夹    For i = 1 To UBound(parts)        If parts(i) <> "" Then            currentPath = currentPath & "\" & parts(i)            ' 如果文件夹不存在，则创建            If Dir(currentPath, vbDirectory) = "" Then                MkDir currentPath            End If        End If    Next i    CreatePathRecursive = True    Exit FunctionErrorHandler:    ' 遇到错误（如文件名包含 \ / : * ? " < > | 等非法字符）    CreatePathRecursive = FalseEnd Function