从Excel打印到pdf时自动分页符

时间:2019-05-08 07:01:11

标签: excel vba

这里是VBA,我用来在打印为pdf时自动插入分页符。如果页面超过一页,代码似乎可以工作。但是,如果文档调试器中只有页面会给出错误

  

运行时错误9:下标超出范围

指向Set r = PrintVersion.Cells(.Item(pb).Location.Row, 1)。任何想法是什么问题以及如何解决?

这是我的代码:

    Sub Print()

        Dim Cell As Range
        Dim tempFolderPath As String
        Dim filePath As String
        Dim fileTitle As String
        Dim fnd As Range, r As Range, pb As Variant
        Dim PrintVersion As Worksheet
        Dim WData As Worksheet
        Dim rw As Range, hideRange As Range

        Set PrintVersion = ThisWorkbook.Sheets("Print version")
        Set WData = ThisWorkbook.Sheets("Data")

        With PrintVersion.Range("Print_Area")

                With .Cells.Rows
                    .WrapText = True
                    .VerticalAlignment = xlCenter
                    .EntireRow.AutoFit
                End With

' Hide blank rows with formulas giving as a result ""
        For Each rw In .Rows
            For Each Cell In rw.Cells
                If Cell.HasFormula Then
                    If Cell.Value = "" Then
                        If Not rw.Hidden Then
                            If hideRange Is Nothing Then
                                Set hideRange = rw
                            Else
                                Set hideRange = Union(hideRange, rw)
                            End If
                            Exit For    ' no need to process rest of the row
                       End If
                    End If
                End If
            Next
        Next
        If Not hideRange Is Nothing Then hideRange.EntireRow.Hidden = True
        End With

' Set print area till the last cell
        PrintVersion.PageSetup.PrintArea = PrintVersion.Range("A1:C" & _
        PrintVersion.[LOOKUP(2,1/(C1:C250<>""),ROW(C1:C250))]).Address


           ' make sure sheet is in page break view
            PrintVersion.Parent.Windows(1).View = xlPageBreakPreview

        ' first clear any set page breaks
        PrintVersion.ResetAllPageBreaks

        ' move preposed breaks to top of segement
        With PrintVersion.HPageBreaks

            pb = 1
            Do
                ' check if first column is empty
                Set r = PrintVersion.Cells(.Item(pb).Location.Row, 1)
                If r.Value = "" Then
                    ' find previous cell in column 1 which is not empty
                    Set fnd = PrintVersion.Columns(1).Find("*", r, , , , xlPrevious)
                    ' set page break 1 row above it
                    Set .Item(pb).Location = fnd.Offset(-1, 0)
                    DoEvents

                End If
                pb = pb + 1
                If pb > .Count Then Exit Do
            Loop
        End With

        ' create a path for a temporary file
        tempFolderPath = Environ("Temp")
        fileTitle = "CV_" & Sheets("Filling form").Range("F7") & "_" & Sheets("Filling form").Range("F9")
        filePath = tempFolderPath & "\" & fileTitle & ".pdf"

        PrintVersion.ExportAsFixedFormat xlTypePDF, filePath, xlQualityStandard, True, , , , False

        Set PrintVersion = Nothing
        Set WData = Nothing

    End Sub

1 个答案:

答案 0 :(得分:1)

因此,如果没有分页符,则不需要处理它们,对吗?在检查之前是否有任何东西:

 With PrintVersion.HPageBreaks
    If .Count > 0 Then
        pb = 1
        Do
            ' check if first column is empty
            Set r = PrintVersion.Cells(.Item(pb).Location.Row, 1)
            If r.Value = "" Then
                ' find previous cell in column 1 which is not empty
                Set fnd = PrintVersion.Columns(1).Find("*", r, , , , xlPrevious)
                ' set page break 1 row above it
                Set .Item(pb).Location = fnd.Offset(-1, 0)
                DoEvents

            End If
            pb = pb + 1
            If pb > .Count Then Exit Do
        Loop
    End If
End With

(未经测试)