Как добавить исключения при создании PDF-файлов в соответствии со списком Excel с помощью макросов

Question

Привет, я скачал файл Excel с макросами, который генерирует PDF-файлы в соответствии со списком. Имеется 2 листа, и файл pdf генерируется из листа, называемого «WEST», для их генерации он использует функцию автофильтра в столбце D, поэтому он генерирует файл pdf для каждого уникального значения, указанного в списке на листе, называемом «ПРАКТИКА».

Вот ссылка на файл http://nhsexcel.com/filtered-list-to-pdf/

Дело в том, что я хочу добавить исключения в код, например, я не хочу генерировать pdf-строки из строк на листе "WEST", которые содержат в столбце 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 больше десяти, но независимо от того, что я пробовал, оно либо генерирует все pdf, либо не генерирует вообще.

Answer 1

Я думаю, что вы хотите, чтобы оператор 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