如何修改VBA代码实现按Excel单元格C1的值指定文件夹保存路径

修改后可满足需求的VBA代码 #

Sub MakeFolders()
    Dim Rng As Range, rw As Range, c As Range
    Dim p As String, v As String
    Dim suffixPath As String
    
    ' 校验工作簿是否已保存
    If ActiveWorkbook.Path = "" Then
        MsgBox "请先保存当前工作簿，否则无法获取根路径", vbExclamation
        Exit Sub
    End If
    
    ' 读取C1单元格的路径后缀
    suffixPath = Trim(Range("C1").Value)
    If suffixPath = "" Then
        MsgBox "请在C1单元格填入目标路径后缀", vbExclamation
        Exit Sub
    End If
    
    ' 拼接生成文件夹的基础根路径，统一处理末尾分隔符
    p = ActiveWorkbook.Path & "\" & suffixPath
    If Right(p, 1) <> "\" Then p = p & "\"
    
    Set Rng = Selection
    If Rng.Count = 0 Then
        MsgBox "请先选中要生成层级文件夹的单元格区域", vbExclamation
        Exit Sub
    End If

    ' 逐行处理选中区域，生成层级文件夹
    For Each rw In Rng.Rows
        Dim currentRowPath As String
        currentRowPath = p ' 每行重置路径为基础根路径
        For Each c In rw.Cells
            v = Trim(c.Value)
            If Len(v) > 0 Then
                ' 文件夹不存在则创建
                If Len(Dir(currentRowPath & v, vbDirectory)) = 0 Then 
                    MkDir currentRowPath & v
                End If
                ' 拼接当前层级路径，用于下一级文件夹生成
                currentRowPath = currentRowPath & v & "\"
            End If
        Next c
    Next rw
    MsgBox "所有文件夹生成完成", vbInformation
End Sub

改动说明 #

• 新增工作簿保存状态校验：未保存的工作簿无法获取根路径，运行时会主动提示避免报错
• 新增C1单元格值读取逻辑：自动将C1填入的路径段拼接在工作簿根路径后，作为生成文件夹的基础路径
• 新增空值校验：C1未填内容、未选中单元格区域时都会主动提示，避免逻辑异常
• 兼容路径格式：自动处理路径末尾的分隔符，无论C1填入的路径最后是否带反斜杠都能正常拼接
• 保留原代码的核心逻辑：仍然支持选中多行多列区域生成层级文件夹，原有使用方式不变

使用方法 #

1. 在当前工作表的C1单元格填入目标路径后缀，比如示例中的games\new
2. 选中要生成层级文件夹的单元格区域
3. 运行MakeFolders宏即可，所有文件夹都会生成在工作簿根路径\C1填写的路径\对应的层级下

内容的提问来源于stack exchange，提问作者John Holmes