VBA Excel在新建多级文件夹保存文件时触发1004错误求助

问题 #

新增一级子文件夹后，使用VBA将Excel文件保存到目标目录时持续触发1004错误，提示路径未找到。仅直接使用PathName时SaveAs可以正常工作，尝试用NewSubFolderPath & Application.PathSeparator & fileName & "-file"拼接路径也无效。

代码如下：

Dim BPcode As String, GPcode As String, PCity As String, Folder1 As String, Folder2 As String
Dim Target As Range
Dim SelectedRow As Long

Dim PathName As String, fileName As String

Set Target = ActiveCell

SelectedRow = Target.Row

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

PathName = GetLocalPath(ThisWorkbook.path)
fileName = RemoveForbiddenFilenameChars(WAddress)

BPcode = Split(PCode, " ")(0)
GPcode = Remove_Number(BPcode)

Select Case GPcode
Case "CB"
PCity = "Cambridge"
Case "NN"
PCity = "Northampton"
End Select

Folder1 = RemoveForbiddenFilenameChars(UCase(PCity)) & " [" & GPcode & "]"
Folder2 = RemoveForbiddenFilenameChars(UCase(City))

If Folder2 = "" Then MsgBox "What is the Site Address City?", vbCritical: Exit Sub
If fileName = "" Then MsgBox "Address incorrect or not provided", vbCritical: Exit Sub

Dim NewFolderPath As String
NewFolderPath = PathName & Application.PathSeparator & Folder1
If Dir(NewFolderPath, vbDirectory) = "" Then
MkDir NewFolderPath
Else
MsgBox "The Folder " & Folder1 & " already exists"
End If

Dim NewSubFolderPath As String
NewSubFolderPath = NewFolderPath & Application.PathSeparator & Folder2
If Dir(NewSubFolderPath, vbDirectory) = "" Then
MkDir NewSubFolderPath
Else
MsgBox "The Folder " & Folder2 & " already exists"
End If

Set wkb = Workbooks.Add

With wkb

Application.DisplayAlerts = False

.SaveAs fileName:=NewSubFolderPath & "\" & fileName & "- file", FileFormat:=xlOpenXMLWorkbookMacroEnabled

排查解决方案 #

• 强制验证完整路径：在SaveAs语句前添加代码，弹出最终保存路径，确认是否存在非法字符、空片段或格式错误：

  MsgBox NewSubFolderPath & Application.PathSeparator & fileName & "- file"
  

  重点检查Folder1、Folder2是否生成了合法值，RemoveForbiddenFilenameChars函数是否漏处理了特殊字符（比如:、*、?等）。

• 修正路径拼接的分隔符问题：自定义函数GetLocalPath可能返回带末尾分隔符的路径，导致后续拼接出现重复分隔符。添加代码统一处理：

  PathName = GetLocalPath(ThisWorkbook.path)
  If Right(PathName, 1) = Application.PathSeparator Then
      PathName = Left(PathName, Len(PathName) - 1)
  End If
  

• 改用递归创建多级目录：MkDir无法创建嵌套的多级目录（如果Folder1创建失败，Folder2也会出错），替换原有的目录创建代码为递归函数：

  Sub CreateFolder(ByVal folderPath As String)
      If Dir(folderPath, vbDirectory) = "" Then
          ' 先创建父目录
          CreateFolder Left(folderPath, InStrRev(folderPath, Application.PathSeparator) - 1)
          MkDir folderPath
      End If
  End Sub
  

  调用时直接执行CreateFolder NewSubFolderPath，无需分两次创建父文件夹和子文件夹。

• 确保单元格取值正确：当前代码直接传递单元格对象给RemoveForbiddenFilenameChars函数，若函数仅处理字符串，需改为传递单元格值：

  fileName = RemoveForbiddenFilenameChars(WAddress.Value)
  Folder2 = RemoveForbiddenFilenameChars(UCase(City.Value))
  

• 补充文件后缀：xlOpenXMLWorkbookMacroEnabled对应.xlsm后缀，手动添加可避免格式识别错误：

  .SaveAs fileName:=NewSubFolderPath & Application.PathSeparator & fileName & "- file.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
  

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