Question

这是我的问题：我需要将动态范围导出到工作表然后导出到新工作簿然后导出为PDF，我的问题是每次我的pdf创建分页符都与第一页不同我不知道该怎么办

请帮助我并提前抱歉长码

但我需要帮助;）

我的代码如下

RR.Copy

        wsBS.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
         'Define same Column idth and Row hight for copied range
        Dim r As Long, c As Long
        Dim SourceRange As Range, TargetRange As Range
        Set SourceRange = RR
       Set TargetRange = wsBS.UsedRange

Workbooks.Open FileName:="C:\Users\User\Documents\Tests Salome\dailypdf.xlsx"

Dim wbto As Workbook: Set wbto = Workbooks("dailypdf.xlsx")
Dim sht As Worksheet

 wb.Activate
  For Each sht In Sheets
If sht.Name <> "BS" And sht.Name <> "Balance" Then
Else
sht.Copy Before:=wbto.Sheets(wbto.Sheets.Count)
    sht.PageSetup.PrintArea = UsedRange

End If
Debug.Print sht.Name
Next

Sheets("BS").Cells.Delete
 wbto.Activate
 Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True

 Dim wsto As Worksheet: Set wsto = wbto.Sheets("BS")

   With wsto.PageSetup
       .AlignMarginsHeaderFooter = wsEUR.PageSetup.AlignMarginsHeaderFooter
     .BlackAndWhite = wsEUR.PageSetup.BlackAndWhite
      .BottomMargin = wsEUR.PageSetup.BottomMargin
      .LeftMargin = wsEUR.PageSetup.LeftMargin
      .Orientation = wsEUR.PageSetup.Orientation
      .PaperSize = wsEUR.PageSetup.PaperSize
      .RightHeaderPicture.FileName = wsEUR.PageSetup.RightHeaderPicture.FileName
       .RightMargin = wsEUR.PageSetup.RightMargin
      .TopMargin = wsEUR.PageSetup.TopMargin
       .Zoom = wsEUR.PageSetup.Zoom
     End With


            FileName = Create_PDF(Source:=wbto, _
                                      FixedFilePathName:=iFile, _
                                      OverwriteIfFileExist:=True, _
                                      OpenPDFAfterPublish:=False)

谢谢你，抱歉这个长代码......

Answer 1

代码已更新：

Sub CopyPageBreaks(Source As Worksheet, Dest As Worksheet)
    Dim BeforeCell As Range, lBreak As Long

    Dest.ResetAllPageBreaks 'Delete existing Page-Breaks

    'Horizontal Page Breaks
    For lBreak = 0 To Source.HPageBreaks.Count
        If lBreak > 0 Then
            Set BeforeCell = Source.HPageBreaks(lBreak).Location
            Dest.HPageBreaks.Add Before:=Dest.Cells(BeforeCell.Row, BeforeCell.Column) 'Copy from source
        End If
    Next lBreak

    'Vertical Page Breaks
    For lBreak = 0 To Source.VPageBreaks.Count
        If lBreak > 0 Then
            Set BeforeCell = Source.VPageBreaks(lBreak).Location
            Dest.VPageBreaks.Add Before:=Dest.Cells(BeforeCell.Row, BeforeCell.Column) 'Copy from source
        End If
    Next lBreak

    Set BeforeCell = Nothing
End Sub

{EDITED} 以下旧代码

尝试这样的事情:(目前无法测试）

Sub CopyPageBreaks(Source AS Worksheet, Dest As Worksheet)
    Dim pb AS Object, BeforeCell AS Range

    'Horizontal Page Breaks
    Dest.HPageBreaks.Delete 'Delete existing Page-Breaks
    For Each pb In Source.HPageBreaks
        Set BeforeCell = pb.Range
        Dest.HPageBreaks.Add Before:=Dest.Cells(BeforeCell.Row, BeforeCell.Column) 'Copy from source
    Next pb

    'Vertical Page Breaks
    Dest.VPageBreaks.Delete 'Delete existing Page-Breaks
    For Each pb In Source.VPageBreaks
        Set BeforeCell = pb.Range
        Dest.VPageBreaks.Add Before:=Dest.Cells(BeforeCell.Row, BeforeCell.Column) 'Copy from source
    Next pb

    Set BeforeCell = Nothing
End Sub

将工作表导出到新的动态工作簿，然后以相同的分页符导出PDF

1 个答案: