如何使用宏根据excel列表在创建pdf文件中添加异常

问题描述 投票:0回答:1

嗨,我下载了一个带有宏的excel文件,根据列表生成pdf文件。有两张纸,pdf是从名为“WEST”的纸张生成的,生成它们在D列中使用自动过滤功能,因此它会从名为“PRACTICE”的纸张列表中指定的每个唯一值生成一个pdf。

这是http://nhsexcel.com/filtered-list-to-pdf/文件的链接

问题是我想在代码中添加例外,例如我不想生成表单“WEST”中行的pdf,其中包含列i中小于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$8:$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

我想生成所有行的pdf文件,其中第I列的值大于10,但无论我尝试过什么,它都会生成所有pdf或者根本不生成任何内容。

excel vba if-statement pdf-generation autofilter
1个回答
0
投票

我想你想要一个IF语句来检查在继续导出之前是否有任何行可见(不包括标题)。

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

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$8:$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
© www.soinside.com 2019 - 2024. All rights reserved.