VBA Excel：将文件保存至新建文件夹时遇错误的解决求助

问题背景 #

需要将新建工作簿保存到对应城市的文件夹中，三次代码尝试均出现问题，逐一分析并解决：

初始代码问题：持续提示目录不存在 #

代码：

Dim City as Range
Dim Saverng as Range
Dim PathName As String
Dim FolderName As String

Set Target = ActiveCell
SelectedRow = Target.Row

Set City = cstws.Range("L" & SelectedRow)
Set Saverng = cstws.Range("K" & SelectedRow)

PathName = ThisWorkbook.path & "\test\"
FolderName = UCase(City)

If Dir(PathName & FolderName, vbDirectory) = "" Then
     MkDir PathName & FolderName
Else
     MsgBox "The folder " & FolderName & " already exists"
End If

Set wkb = Workbooks.Add

With wkb
     .SaveAs filename:=PathName & FolderName & "\" & Saverng & " - Pre-Survey Template V1.1.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled

问题根源：

• MkDir仅能创建单级目录，若ThisWorkbook.path下的test文件夹本身不存在，执行创建城市文件夹的代码会直接报错，因为父目录缺失。
• 直接用UCase(City)时，City是Range对象，虽默认取单元格Value，但如果单元格内容包含斜杠、冒号等特殊字符，会导致路径无效。
• 未确认cstws工作表对象是否提前定义，若未赋值会引发对象未定义错误。

第一次更新代码问题：误报文件夹已存在 #

代码：

PathName = ThisWorkbook.path & "\test\"
FolderName = UCase(City)

If FolderName = vbNullString Then
     If City = "" Then
          MsgBox ("What is the Site Address City?")
          Exit Sub
     Else
          MkDir (PathName & FolderName)
     End If
Else
     MsgBox ("The Folder " & UCase(City) & " already exists")
End If

问题根源：

• 判断逻辑完全错误：只要City单元格有值，FolderName就不会等于vbNullString，直接进入Else分支提示文件夹已存在，根本不会执行创建文件夹的逻辑。

第二次更新代码问题：仅能保存单个文件，第二次保存报1004错误 #

代码：

PathName = Application.ThisWorkbook.path & "\test\"
FolderName = UCase(City)

If City = "" Then
   MsgBox ("What is the Site Address City?")
   Exit Sub
End If

If Dir(PathName & FolderName, vbDirectory) = "" Then
MkDir (PathName & FolderName)
Else
MsgBox ("The Folder " & UCase(City) & " already exists")
End If

Set wkb = Workbooks.Add

With wkb
   .SaveAs filename:=PathName & FolderName & "\" & WAddress & " - Pre-Survey Template V1.1.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled

问题根源：

• 未关闭之前创建的工作簿，导致同名文件被占用（若WAddress重复），或Excel进程残留未关闭的工作簿引发权限问题。
• 未处理WAddress变量有效性：如果变量未定义、为空或含非法字符，会导致保存路径无效。
• 依然未解决test文件夹不存在时的创建问题。

修正后的完整代码 #

Sub SaveToCityFolder()
    Dim City As Range
    Dim SaveName As Range
    Dim PathName As String
    Dim FullFolderPath As String
    Dim SaveFilePath As String
    Dim cstws As Worksheet
    Dim wkb As Workbook
    
    ' 定义目标工作表（替换为你的实际工作表名称）
    Set cstws = ThisWorkbook.Worksheets("Sheet1")
    
    ' 获取选中行的城市和保存名称
    Set City = cstws.Range("L" & ActiveCell.Row)
    Set SaveName = cstws.Range("K" & ActiveCell.Row)
    
    ' 检查必填内容是否为空
    If Trim(City.Value) = "" Then
        MsgBox "请填写站点所在城市！"
        Exit Sub
    End If
    If Trim(SaveName.Value) = "" Then
        MsgBox "请填写保存文件名！"
        Exit Sub
    End If
    
    ' 构建基础路径
    PathName = ThisWorkbook.Path & "\test\"
    FullFolderPath = PathName & UCase(Trim(City.Value))
    
    ' 使用FileSystemObject递归创建文件夹（支持创建父目录）
    With CreateObject("Scripting.FileSystemObject")
        ' 先创建test文件夹（如果不存在）
        If Not .FolderExists(PathName) Then
            .CreateFolder PathName
        End If
        ' 创建城市文件夹（如果不存在）
        If Not .FolderExists(FullFolderPath) Then
            .CreateFolder FullFolderPath
        Else
            MsgBox "城市文件夹 " & UCase(Trim(City.Value)) & " 已存在"
        End If
    End With
    
    ' 清理文件名非法字符并构建完整保存路径
    SaveFilePath = FullFolderPath & "\" & CleanFileName(SaveName.Value) & " - Pre-Survey Template V1.1.xlsm"
    
    ' 创建、保存并关闭工作簿，释放资源
    Set wkb = Workbooks.Add
    With wkb
        .SaveAs Filename:=SaveFilePath, FileFormat:=xlOpenXMLWorkbookMacroEnabled
        .Close SaveChanges:=False
    End With
    
    ' 释放对象内存
    Set wkb = Nothing
    Set City = Nothing
    Set SaveName = Nothing
    Set cstws = Nothing
End Sub

' 辅助函数：移除文件名中的非法字符
Function CleanFileName(strName As String) As String
    Dim illegalChars As Variant
    Dim i As Integer
    illegalChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    
    For i = LBound(illegalChars) To UBound(illegalChars)
        strName = Replace(strName, illegalChars(i), "")
    Next i
    CleanFileName = Trim(strName)
End Function

关键修复点说明 #

1. 递归创建文件夹：用Scripting.FileSystemObject替代MkDir，可自动创建不存在的父目录（如test文件夹），避免目录缺失错误。
2. 修正逻辑判断：先检查单元格内容是否为空，再判断文件夹是否存在，逻辑更严谨。
3. 处理非法字符：新增CleanFileName函数，移除文件名中的禁用字符，避免保存路径无效。
4. 释放文件占用：创建工作簿后及时关闭，解决第二次保存时的1004权限错误。
5. 明确对象定义：提前定义cstws工作表对象，避免未定义错误。

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