Создать PDF с указанными диапазонами c на одном листе с помощью макроса Excel

Question

Я могу создать PDF в диапазоне, но количество страниц не может быть стандартизировано. так что есть ли возможность обновить мой макрос для создания 4-страничного PDF в пределах моего известного диапазона.

Dim fso As Object
Dim s(1) As String
Dim sNewFilePath As String
Dim pg1 As Range
Dim pg2 As Range
Dim pg3 As Range
Dim pg4 As Range
Dim r As Range
Dim ws As Worksheet
    Set ws = ActiveSheet
     With ws.PageSetup
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .FitToPagesWide = 1
    End With
Set pg1 = ActiveSheet.Range("A1:K92")
Set pg2 = ActiveSheet.Range("A93:K164")
Set pg3 = ActiveSheet.Range("A165:K237")
Set pg4 = ActiveSheet.Range("A239:K313")
Set r = Union(pg1, pg2, pg3, pg4)
    Set fso = CreateObject("Scripting.FileSystemObject")
    s(0) = ThisWorkbook.FullName

    If fso.FileExists(s(0)) Then
        '//Change Excel Extension to PDF extension in FilePath
        s(1) = fso.GetExtensionName(s(0))
        If s(1) <> "" Then
            s(1) = "." & s(1)
            sNewFilePath = Replace(s(0), s(1), ".pdf")


                r.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:=sNewFilePath, _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, OpenAfterPublish:=True
        End If
    Else
        '//Error: file path not found
        MsgBox "Error: this workbook may be unsaved.  Please save and try again."
    End If

    Set fso = Nothing
ActiveWorkbook.Save
ActiveWindow.Close

это не работает, как я себе представляю. я также попробовал hpagebreaks.add и не могу с этим справиться.

так у вас есть идеи?

Answer 1

Вообще-то, я пошел по твоему следу и попросил моего друга за свободные sh глаза. он просто в основном решил это с помощью записи макроса. это работает сейчас. @ Кирилл, спасибо тебе и твоему времени.

   Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 4
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = False
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = "$C$1:$K$312"
    ActiveSheet.ResetAllPageBreaks
    Set ActiveSheet.HPageBreaks(1).Location = Range("C93")
    Set ActiveSheet.HPageBreaks(2).Location = Range("C165")
    Set ActiveSheet.HPageBreaks(3).Location = Range("C239")

    Dim FileName As String
    Application.DisplayAlerts = False
    On Error Resume Next

    sPath = ThisWorkbook.Path
    With Worksheets("Final")

        FileName = ThisWorkbook.FullName
                               .ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Left(FileName, InStr(FileName, ".") - 1), _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=True
    End With

Answer 2

В ответ на запрошенный код, который я пробовал при тестировании (это очень похоже на то, что вы имеете в своем коде, используя Union() и затем экспортируете):

Пример кода ниже:

Private Sub printToPDF()
    Dim printArea1 As Range
    Set printArea1 = Range(Cells(1, "A"), Cells(11, "R"))
    Dim printarea2 As Range
    Set printarea2 = Cells(61, "A")
    Dim completePrintRange As Range
    Set completePrintRange = Union(printArea1, printarea2)
    completePrintRange.ExportAsFixedFormat xlTypePDF, "Test", , , , , , True
End Sub

Обратите внимание, что экспорт будет иметь каждый диапазон на отдельной странице в PDF. Перемещение по столбцам переходит на следующую страницу, например, printArea1 на двух страницах. Это связано с размером бумаги и масштабированием.