点击Excel每日一学，关注星标★不迷路
还在手动新建文件夹？用这段VBA代码，让Excel帮你自动生成多层嵌套文件夹！
✨ 功能亮点：
💡 使用场景： 项目文档归档、学期课程整理、客户资料管理……只要你有层级分类需求，它都能轻松搞定！
代码：
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
📝 使用方法：
代码已包含完整错误处理和状态反馈，安全可靠。快收藏分享给需要的小伙伴吧！
#Excel技巧 #办公自动化 #VBA #效率工具
由于公众号平台更改了推送规则，为确保您能及时收到Excel每日一学的原创分享，请记得关注公众号并设为星标⭐，同时欢迎转发
、点赞
或在看
。也欢迎扫描下方二维码加我个人微信相互学习交流
📥 获取方式 关注后回复“批量创建嵌套文件夹”获取下载链接
