T4093_Export To One PDF All Names Blocks

https://excel-egy.com/forum/t4093
---------------------------------

Sub Export_To_One_PDF_All_Names_Block()
    Dim wb As Workbook, ws As Worksheet, sh As Worksheet, lr As Long, m As Long, r As Long

    Application.ScreenUpdating = False
        Set wb = Workbooks.Add(xlWBATWorksheet)
        Set ws = ThisWorkbook.Worksheets("Sheet1")
        Set sh = ThisWorkbook.Worksheets("Template")
        lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
        m = 2: r = 1

        Do Until m >= lr
            sh.Copy After:=wb.Worksheets(wb.Worksheets.Count)

            With ActiveSheet
                .Range("D13").Resize(16, 2).Value = ws.Range("A" & m).Resize(16, 2).Value

                Application.PrintCommunication = False
                    With .PageSetup
                        .PrintArea = "$A$1:$G$38"
                        .RightHeader = "&""Arial,Bold""&12 " & r
                        .Orientation = xlPortrait
                        .FitToPagesWide = 1
                        .FitToPagesTall = False
                    End With
                Application.PrintCommunication = True
            End With
            m = m + 16: r = r + 1
        Loop

        Application.DisplayAlerts = False
            wb.Worksheets(1).Delete
        Application.DisplayAlerts = True

        wb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Environ("USERPROFILE") & "\Desktop\" & "Final Output" & ".pdf"
        wb.Close SaveChanges:=False
    Application.ScreenUpdating = True

    MsgBox "The PDF File Equals To ( " & r - 1 & " ) Pages", vbInformation
End Sub