Excel VBA按单元格引用路径导出PDF遇1004运行时错误求助

我尝试将30页的Excel报表保存/打印为PDF，文件路径与文件名通过单元格引用设置。运行以下VBA代码时出现运行时错误1004，提示"Document not saved. an error may be encountered when saving"，需要排查解决问题。

Sub PrintToPDF()
    Dim ws As Worksheet
    Dim vDir As String
    Dim pdfName As String
    Dim fileSaveName As String
    Dim separator As String: separator = Application.PathSeparator
    Dim FSO As Object

    ' Set the worksheet to print (e.g., "REPORT" sheet)
    Set ws = ThisWorkbook.Sheets("REPORT")

    ' Get the folder path from INPUT!B6
    vDir = ThisWorkbook.Sheets("INPUT").Range("B6").Value

    ' Get the file name from INPUT!B5
    pdfName = ThisWorkbook.Sheets("INPUT").Range("B9").Value

    If vDir = "" Or pdfName = "" Then
        MsgBox "Folder path or file name is missing. Please provide both a folder path and a file name."
        Exit Sub
    End If

    ' Check if the folder exists, and create it if it doesn't
    If Dir(vDir, vbDirectory) = "" Then
        MkDir vDir
    End If

    ' Check if the file name has a ".pdf" extension
    If Right(pdfName, 4) <> ".pdf" Then
        pdfName = pdfName & ".pdf"
    End If

    ' Build the full file path
    fileSaveName = vDir & separator & pdfName

    ' Create a FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")

    ' Check if the file already exists
    If Not FSO.FileExists(fileSaveName) Then
        ' Set the print area for the "REPORT" sheet (e.g., A1:AK2107)
        ws.PageSetup.PrintArea = "A1:AK2107"

        ' Export the "REPORT" sheet as PDF and open it after publishing
        ws.ExportAsFixedFormat Type:=xlTypePDF, fileName:=fileSaveName, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
        MsgBox "PDF File Saved in " & vDir

        ' Clear the print area setting
        ws.PageSetup.PrintArea = ""
    Else
        MsgBox "This PDF file already exists in the same system folder. or May be Opened"
    End If

    ' Release the FileSystemObject
    Set FSO = Nothing
End Sub

可能的报错原因及解决方法 #

• 多级目录创建失败：原代码用MkDir只能创建单级目录，如果单元格B6里的路径是多级（比如D:\Reports\2024\Q3），当上级目录不存在时会直接报错。替换为FileSystemObject的多级创建逻辑：

  If Not FSO.FolderExists(vDir) Then
      FSO.CreateFolder vDir
  End If
  

• 文件名含非法字符：Windows文件名不能包含\/:*?"<>|，需检查并替换这些字符：

  Dim illegalChars As Variant, char As Variant
  illegalChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
  For Each char In illegalChars
      pdfName = Replace(pdfName, char, "_")
  Next char
  

• 文件被占用或权限不足：原代码仅判断文件是否存在，若目标PDF已被打开或保存路径无写入权限（如C:\根目录），导出会失败。需添加错误捕获：

  On Error Resume Next
  ws.ExportAsFixedFormat Type:=xlTypePDF, fileName:=fileSaveName, _
      Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
  If Err.Number <> 0 Then
      MsgBox "保存失败：文件可能被占用、路径无写入权限或打印区域无效"
      Err.Clear
      Exit Sub
  End If
  On Error GoTo 0
  

• 打印区域无效：确认A1:AK2107范围在REPORT工作表中真实存在，可改为动态获取打印区域：

  ws.PageSetup.PrintArea = ws.UsedRange.Address
  

• 路径格式错误：检查单元格B6的路径是否以路径分隔符结尾，避免拼接时出现格式错误：

  If Right(vDir, 1) <> separator Then
      vDir = vDir & separator
  End If
  

修改后的完整代码 #

Sub PrintToPDF()
    Dim ws As Worksheet
    Dim vDir As String
    Dim pdfName As String
    Dim fileSaveName As String
    Dim separator As String: separator = Application.PathSeparator
    Dim FSO As Object
    Dim illegalChars As Variant, char As Variant

    ' 目标工作表设置
    Set ws = ThisWorkbook.Sheets("REPORT")
    Set FSO = CreateObject("Scripting.FileSystemObject")

    ' 读取单元格中的路径和文件名
    vDir = ThisWorkbook.Sheets("INPUT").Range("B6").Value
    pdfName = ThisWorkbook.Sheets("INPUT").Range("B9").Value

    ' 空值校验
    If vDir = "" Or pdfName = "" Then
        MsgBox "文件夹路径或文件名不能为空，请填写完整"
        Exit Sub
    End If

    ' 修正路径格式
    If Right(vDir, 1) <> separator Then
        vDir = vDir & separator
    End If

    ' 创建多级目录（如果不存在）
    If Not FSO.FolderExists(vDir) Then
        FSO.CreateFolder vDir
    End If

    ' 清理文件名中的非法字符
    illegalChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    For Each char In illegalChars
        pdfName = Replace(pdfName, char, "_")
    Next char

    ' 补充PDF扩展名（如果缺失）
    If LCase(Right(pdfName, 4)) <> ".pdf" Then
        pdfName = pdfName & ".pdf"
    End If

    ' 拼接完整文件路径
    fileSaveName = vDir & pdfName

    ' 检查文件是否存在或被占用
    If FSO.FileExists(fileSaveName) Then
        MsgBox "文件已存在或正被其他程序占用，请关闭后重试"
        Exit Sub
    End If

    ' 设置打印区域为已使用范围（可根据需求调整）
    ws.PageSetup.PrintArea = ws.UsedRange.Address

    ' 导出PDF并处理错误
    On Error Resume Next
    ws.ExportAsFixedFormat Type:=xlTypePDF, fileName:=fileSaveName, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    
    If Err.Number <> 0 Then
        MsgBox "导出失败：" & Err.Description & vbCrLf & "请检查路径权限、文件占用或打印区域"
        ws.PageSetup.PrintArea = ""
        Set FSO = Nothing
        Exit Sub
    End If
    On Error GoTo 0

    MsgBox "PDF已保存至：" & vDir
    ws.PageSetup.PrintArea = ""

    ' 释放对象
    Set FSO = Nothing
End Sub

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