如何使用宏根据 excel 列表在创建 pdf 文件时添加例外

Question

您好，我下载了一个 excel 文件，其中包含根据列表生成 pdf 文件的宏。有 2 个 sheet，pdf 是从 sheet 生成的，称为 "WEST" 生成它们它使用 D 列中的自动筛选函数，因此它为在sheet 中名为 "PRACTICE" 的列表。

这是 link 文件 http://nhsexcel.com/filtered-list-to-pdf/

问题是我想在代码中添加例外，例如我不想生成 sheet "WEST" 中包含在列中的行的 pdf我的值小于 10.

我试图添加一个符合该标准的自动过滤器，但代码一直说它不是一个有效的方法。

Sub PracticeToPDF()
'Prepared by Dr Moxie

    Dim ws As Worksheet
    Dim ws_unique As Worksheet
    Dim DataRange As Range
    Dim iLastRow As Long
    Dim iLastRow_unique As Long
    Dim UniqueRng As Range
    Dim Cell As Range
    Dim LastRow As Long
    Dim LastColumn As Long

    Application.ScreenUpdating = False

    'Note that the macro will save the pdf files in this active directory so you should save in an appropriate folder
    DirectoryLocation = ActiveWorkbook.Path

    Set ws = Worksheets("WEST") 'Amend to reflect the sheet you wish to work with
    Set ws_unique = Worksheets("PRACTICE") 'Amend to reflect the sheet you wish to work with

    'Find the last row in each worksheet
    iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    iLastRow_unique = ws_unique.Cells(Rows.Count, "A").End(xlUp).Row


    With ws
        'I've set my range to reflect my headers which are fixed for this report
        Set DataRange = ws.Range("$A:$L$" & iLastRow)

        'autofilter field is 4 as I want to print based on the practice value in column D
        DataRange.AutoFilter Field:=4

        Set UniqueRng = ws_unique.Range("A4:A" & iLastRow_unique)
        For Each Cell In UniqueRng
            DataRange.AutoFilter Field:=4, Criteria1:=Cell

        Name = DirectoryLocation & "\" & Cell.Value & " Practice Report" & ".pdf"

        ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Name _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False

        Next Cell

    End With
    With ws
         .Protect Userinterfaceonly:=True, _
         DrawingObjects:=False, Contents:=True, Scenarios:= _
        True, AllowFormattingColumns:=True, AllowFormattingRows:=True
         .EnableOutlining = True
         .EnableAutoFilter = True
         If .FilterMode Then
            .ShowAllData
         End If
     End With
    Application.ScreenUpdating = True

End Sub

我只想生成第 I 列中值大于 10 的所有行的 pdf 文件，但无论我尝试了什么，它要么生成所有 pdf，要么根本不生成任何 pdf。

Answer 1

我认为您需要一个 IF 语句来检查是否有任何行可见（不包括 headers），然后再继续导出。

这就是我在下面的代码中所做的。

Option Explicit

Sub PracticeToPDF()

    Dim dataSheet As Worksheet
    Set dataSheet = Worksheets("WEST") 'Amend to reflect the sheet you wish to work with

    Dim uniqueSheet As Worksheet
    Set uniqueSheet = Worksheets("PRACTICE") 'Amend to reflect the sheet you wish to work with

    'Note that the macro will save the pdf files in this active directory so you should save in an appropriate folder
    Dim directoryLocation As String
    directoryLocation = ActiveWorkbook.Path ' Maybe you should be using Thisworkbook.Path?

    If Len(Dir$(directoryLocation, vbDirectory)) = 0 Then ' Just in case the ActiveWorkbook hasn't been saved.
        MsgBox "'" & directoryLocation & "' is not a valid path. Code will stop running now."
        Exit Sub
    End If

    'Find the last row in each worksheet
    Dim lastRowOnDataSheet As Long
    lastRowOnDataSheet = dataSheet.Cells(dataSheet.Rows.Count, "A").End(xlUp).Row

    Dim lastRowOnUniqueSheet As Long
    lastRowOnUniqueSheet = uniqueSheet.Cells(uniqueSheet.Rows.Count, "A").End(xlUp).Row

    'I've set my range to reflect my headers which are fixed for this report
    Dim dataRange As Range
    Set dataRange = dataSheet.Range("$A:$L$" & lastRowOnDataSheet)

    Dim uniqueRange As Range
    Set uniqueRange = uniqueSheet.Range("A4:A" & lastRowOnUniqueSheet)

    'Application.ScreenUpdating = False ' Uncomment this when the code is working.

    If dataSheet.AutoFilterMode Then
        On Error Resume Next
        dataSheet.ShowAllData ' Will throw if filters have already been cleared
        On Error GoTo 0
    End If

    Dim cell As Range
    For Each cell In uniqueRange
        With dataRange
            .AutoFilter Field:=4, Criteria1:=cell ' Filter for whatever unique value we're currently at in the loop
            .AutoFilter Field:=9, Criteria1:=">10" ' Filter column I for values greater than 10

            ' Only export the PDF if the filter leaves at least one row (not including the header row)
            If .Columns(1).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
                Dim fullPathToExportPDFTo As String
                fullPathToExportPDFTo = directoryLocation & "\" & cell.Value & " Practice Report" & ".pdf"

                dataSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fullPathToExportPDFTo, _
                        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                        IgnorePrintAreas:=False, OpenAfterPublish:=False
            End If
            .Parent.ShowAllData ' Reset the filter for the loop iteration.
        End With
    Next cell

    With dataSheet
        .Protect Userinterfaceonly:=True, DrawingObjects:=False, Contents:=True, Scenarios:=True, _
            AllowFormattingColumns:=True, AllowFormattingRows:=True
        .EnableOutlining = True
        .EnableAutoFilter = True
     End With
'    Application.ScreenUpdating = True ' Uncomment this when the code is working.
End Sub

如何使用宏根据 excel 列表在创建 pdf 文件时添加例外

How to add exceptions in the creation of pdf files according to an excel list using macros

excel

vba

pdf-generation

if-statement

autofilter