Creating PDF Files

[mnmoxie]

In Excel 2010 I have one workbook with one sheet tab. In the one sheet tab, I am subtotaling with page breaks after each so when I print, I get separate printed documents.

I want to somehow create separate PDF files for each in lieu of printed copies. Is there any way to do this?

Thanks in advance...

 

[Domenic]

For the following solution, you'll need to change the path to the destination folder accordingly. I've assumed that columns A through I contain your data. You can change this as well. Note that the PDF file names are based on the sheet name and page number (ie. SheetName_1, SheetName_2, etc). Also note that if a file by the same name already exists, it will be overwritten.

Option Explicit

Sub CreatePDFsByHorizontalPageBreaks()

    Dim sDestFolder As String
    Dim sFileName As String
    Dim rExportRange As Range
    Dim HPBTotal As Long
    Dim PageTotal As Long
    Dim StartRow As Long
    Dim EndRow As Long
    Dim PageNum As Long
    Dim sErrMsg As String
    
    On Error GoTo ErrHandler
    
    If TypeName(ActiveSheet) <> "Worksheet" Then
        sErrMsg = "Make sure the desired worksheet"
        sErrMsg = sErrMsg & vbCrLf & "is active, and try again."
        GoTo ErrHandler
    End If
    
    sDestFolder = "C:\Users\Domenic\Desktop\"
    If Len(Dir(sDestFolder, vbDirectory)) = 0 Then
        sErrMsg = sDestFolder & " does not exist."
        GoTo ErrHandler
    End If
    
    If Right(sDestFolder, 1) <> "\" Then
        sDestFolder = sDestFolder & "\"
    End If
    
    HPBTotal = ActiveSheet.HPageBreaks.Count
    PageTotal = HPBTotal + 1
    
    StartRow = 1
    For PageNum = 1 To PageTotal
        If PageNum < PageTotal Then
            EndRow = ActiveSheet.HPageBreaks(PageNum).Location.Row - 1
            Set rExportRange = Range(Cells(StartRow, "A"), Cells(EndRow, "I"))
            sFileName = ActiveSheet.Name & "_" & PageNum & ".pdf"
            If Not ExportRangeAsPDF(rExportRange, sDestFolder & sFileName, sErrMsg) Then GoTo ErrHandler
            StartRow = EndRow + 1
        Else
            Set rExportRange = Intersect(ActiveSheet.UsedRange, Range(Cells(StartRow, "A"), Cells(Rows.Count, "I")))
            sFileName = ActiveSheet.Name & "_" & PageNum & ".pdf"
            If Not ExportRangeAsPDF(rExportRange, sDestFolder & sFileName, sErrMsg) Then GoTo ErrHandler
        End If
    Next PageNum
    
    MsgBox "Completed...", vbInformation
        
ExitTheSub:
    Set rExportRange = Nothing
    Exit Sub
    
ErrHandler:
    If Len(sErrMsg) > 0 Then
        MsgBox sErrMsg, vbCritical, "Error"
        GoTo ExitTheSub
    Else
        MsgBox "Error " & Err.Number & ":  " & Err.Description, vbCritical, "Error"
        Resume ExitTheSub
    End If
    
End Sub

Function ExportRangeAsPDF(ByVal rExportRange As Range, ByVal sPathAndFilename As String, ByRef sErrMsg As String) As Boolean
    On Error GoTo ErrHandler
    rExportRange.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPathAndFilename
    ExportRangeAsPDF = True
    Exit Function
ErrHandler:
    sErrMsg = "Error " & Err.Number & ":  " & Err.Description
End Function

Hope this helps!