Excel VBA通过用户窗体勾选导出工作表时PDF及附件缺失问题求助

核心问题排查 #

• 错误捕获未正确关闭：开头检查工作表时开启的On Error Resume Next全程生效，后续所有运行错误都被静默忽略，包括范围定义错误、导出错误等，导致看不到任何报错提示，流程直接跳过导出步骤
• 导出范围定义逻辑缺陷：代码中取A列最后一行向上偏移26行作为导出范围的起始行，如果目标工作表A列数据行数不足27行，lastRng.Offset(-26)会生成无效范围，直接触发错误被跳过，PDF不会生成
• 文件存在性判断参数错误：使用Dir(xStr, vbDirectory)判断文件存在，vbDirectory参数是用于检索文件夹，判断普通文件不需要加该参数，可能导致路径识别异常
• 无导出结果校验逻辑：PDF导出成功与否没有校验，就算导出失败也会把路径写入数组，后续添加附件时找不到文件自然也不会成功

修复后完整代码 #

Private Sub CommandButton1_Click()
 Dim xSht As Worksheet, xFileDlg As FileDialog, xFolder As String, xYesorNo, I, xNum As Integer
 Dim xOutlookObj As Object, xEmailObj As Object, xUsedRng As Range, xArrShetts As Variant
 Dim xPDFNameAddress As String, xStr As String, rngExp As Range, lastRng As Range
 
 xArrShetts = sheetsArr(Me) '保留sheetsArr函数

 '检查工作表存在性
 For I = 0 To UBound(xArrShetts)
    On Error Resume Next
    Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
    If Err.Number <> 0 Or xSht.Name <> xArrShetts(I) Then
        MsgBox "未找到对应工作表，退出操作:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "提示"
        Err.Clear
        On Error GoTo 0 '关闭错误跳过
        Exit Sub
    End If
    Err.Clear
 Next
 On Error GoTo 0 '必须关闭错误跳过，后续报错正常提示

 '选择保存文件夹
 Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
 If xFileDlg.Show = True Then
    xFolder = xFileDlg.SelectedItems(1)
 Else
    MsgBox "请指定PDF保存文件夹。" & vbCrLf & vbCrLf & "点击OK退出宏。", vbCritical, "需指定目标文件夹"
    Exit Sub
 End If

 '确认覆盖规则
 xYesorNo = MsgBox("如果目标文件夹存在同名文件，将自动添加数字后缀区分" & vbCrLf & vbCrLf & "点击Yes继续，点击No取消", _
 vbYesNo + vbQuestion, "文件存在提示")
 If xYesorNo <> vbYes Then Exit Sub

 '循环导出PDF
 For I = 0 To UBound(xArrShetts)
    Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
    
    '生成不重复的保存路径
    xStr = xFolder & "\" & xSht.Name & ".pdf"
    xNum = 1
    '去掉vbDirectory参数，仅判断文件存在
    While Dir(xStr) <> vbNullString
        xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
        xNum = xNum + 1
    Wend

    Set xUsedRng = xSht.UsedRange
    If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
        Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp)
        '先判断行数足够再偏移，避免无效范围
        If lastRng.Row > 26 Then
            Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7))
        Else
            '行数不足时取整个已用范围，可根据业务需求调整规则
            Set rngExp = xSht.UsedRange
        End If
        
        '设置打印参数
        With xSht.PageSetup
              .PaperSize = xlPaperA4
              .PrintArea = rngExp.Address(0, 0)
              .Orientation = xlLandscape
              .FitToPagesWide = 1
              .FitToPagesTall = 1
        End With
        '导出PDF
        rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard, IgnorePrintAreas:=False
    End If
    '导出后校验文件是否存在，不存在则提示
    If Dir(xStr) = vbNullString Then
        MsgBox "工作表" & xSht.Name & "导出PDF失败，请检查范围设置", vbExclamation
    End If
    xArrShetts(I) = xStr
 Next

 '生成Outlook邮件
 Set xOutlookObj = CreateObject("Outlook.Application")
 Set xEmailObj = xOutlookObj.CreateItem(0)
 With xEmailObj
    .Display
    .To = ""
    .CC = ""
    .Subject = "导出PDF附件"
    '添加附件前先校验文件存在
    For I = 0 To UBound(xArrShetts)
        If Dir(xArrShetts(I)) <> vbNullString Then
            .Attachments.Add xArrShetts(I)
        End If
    Next
    '如果需要自动发送，取消下面.Send的注释
    '.Send
 End With
End Sub

Private Function sheetsArr(uF As UserForm) As Variant
  Dim c As MSForms.Control, strCBX As String, arrSh
      For Each c In uF.Controls
            If TypeOf c Is MSForms.CheckBox Then
                If c.Value = True Then strCBX = strCBX & "," & c.Caption
            End If
      Next
      sheetsArr = Split(Mid(strCBX, 2), ",")
End Function

Private Sub CommandButton2_Click()
Unload basicUserform
End Sub

调试说明 #

如果仍然导出失败，代码会弹出具体错误提示，可根据提示进一步调整导出范围规则；如果导出范围固定需要取27行数据，可根据实际业务场景修改行数不足时的处理逻辑。

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