嗨,我下载了一个带有宏的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或者根本不生成任何内容。
我想你想要一个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