Question

我正在寻找有关我的代码的反馈。它目前正在我的测试环境中运行，我想看看是否有人可以找到代码中可能给用户带来麻烦的任何缺陷。

此代码的目的是将每张工作表转换为自己的.PDF，并在给定条件下将其保存在文件夹中。首先会提示我要保存.PDF的位置，然后使用if函数扫描单元格A1（我计划以后更改）以查找电子邮件地址。这些将是我要转换的工作表。

我添加了故障保护功能，因此以前的.PDF不会在用户不知情的情况下被覆盖。转换完所有适用的工作表后，就完成了。

Sub SaveSheetsAsPDF()
    Dim DestFolder As String
    Dim PDFFile As String
    Dim wb As Worksheet
    Dim AlwaysOverwritePDF As Boolean

    'Speed up macro
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    'Prompt for file destination
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            DestFolder = .SelectedItems(1)
        Else
            MsgBox "You must specify a folder to save the PDF into." & _
                vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, _
                "Must Specify Destination Folder"
            Exit Sub
        End If
    End With

    'Create new PDF file name including path and file extension
    For Each wb In ThisWorkbook.Worksheets
        'Test A1 for a mail address
        If wb.Range("A1").Value Like "?*@?*.?*" Then
            PDFFile = DestFolder & Application.PathSeparator & wb.Name & _
                "-" & Format(Date, "mmyy") & ".pdf"
            'If the PDF already exists
            If Len(Dir(PDFFile)) > 0 Then
                If AlwaysOverwritePDF = False Then
                    OverwritePDF = MsgBox(PDFFile & " already exists." & _
                        vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                        vbYesNo + vbQuestion, "File Exists")
                    On Error Resume Next
                    'If you want to overwrite file then delete current one
                    If OverwritePDF = vbYes Then
                        Kill PDFFile
                    Else
                        MsgBox "OK then, if you don't overwrite the " & _
                            "existing PDF, I can't continue." & vbCrLf _
                            & vbCrLf & "Press OK to exit this macro.", _
                            vbCritical, "Exiting Macro"
                        Exit Sub
                    End If
                Else
                    On Error Resume Next
                    Kill PDFFile
                End If
                If Err.Number <> 0 Then
                    MsgBox "Unable to delete existing file.  Please make " & _
                        "sure the file is not open or write protected." _
                        & vbCrLf & vbCrLf & "Press OK to exit this macro.", _
                        vbCritical, "Unable to Delete File"
                    Exit Sub
                End If
            End If
        End If
        'Print PDF
        wb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
    Next wb
    MsgBox "All Files Have Been Converted!"

ResetSettings:
    'Resets optimization settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Answer 1

我在这里看到的问题：

在On Error Resume Next之后没有重置错误处理
缩进并去除多余的空白将大大提高可读性
凌乱。分隔文件删除可以使主逻辑流程更清晰
您可能需要重新考虑工作流程。您是否真的要用户中途退出（可能已经删除了一些文件）退出了？
未声明的变量。添加“显式选项”以捕获该问题

Option Explicit


Sub SaveSheetsAsPDF()
    Dim DestFolder As String
    Dim PDFFile As String
    Dim ws As Worksheet  '<~~ use a more meaningful name
    Dim AlwaysOverwritePDF As Boolean
    Dim FileDate As String

    'Speed up macro
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    'Prompt for file destination
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            DestFolder = .SelectedItems(1) & Application.PathSeparator '<~~ avoids repeating some logic
        Else
            MsgBox "You must specify a folder to save the PDF into." & _
              vbCrLf & vbCrLf & _
              "Press OK to exit this macro.", _
              vbCritical, "Must Specify Destination Folder"
            Exit Sub
        End If
    End With

    'Create new PDF file name including path and file extension
    FileDate = "-" & Format(Date, "mmyy") & ".pdf" '<~~ avoids repeating some logic
    AlwaysOverwritePDF = False '<~~~~ or True, or prompt the user, up to you

    For Each ws In ThisWorkbook.Worksheets
        'Test A1 for a mail address
        If ws.Range("A1").Value Like "?*@?*.?*" Then '<~~ may not be fully robust
            PDFFile = DestFolder & ws.Name & FileDate

            'If the PDF already exists
            If CheckDeleteFile(PDFFile, AlwaysOverwritePDF) Then
                'PDF doesn't exist (any more)

                'Prints PDF
                '<~~~~ probably want this inside the If email
                ws.ExportAsFixedFormat _
                  Type:=xlTypePDF, _
                  Filename:=PDFFile, _
                  Quality:=xlQualityStandard, _
                  IncludeDocProperties:=True, _
                  IgnorePrintAreas:=False, _
                  OpenAfterPublish:=False
            Else
                ' Sheet was skipped, what now?
            End If
        End If
    Next ws
    MsgBox "All Files Have Been Converted!"

ResetSettings:
    'Resets optimization settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
Exit Sub
EH:
    MsgBox "Unexpected Error", Err.Description
    'Add any error handling here
    Resume ResetSettings
End Sub

带循环将工作表转换为单独的PDF

1 个答案: