T4093_Export To One Sheet All Names Block

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

Sub Export_To_One_Sheet_All_Names_Block()
    Dim ws As Worksheet, sh As Worksheet, wsResult As Worksheet, b As Boolean, lr As Long, m As Long, r As Long

    Const sName As String = "Results"
    Const lRows As Long = 38

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

        Application.DisplayAlerts = False
            If Evaluate("ISREF('" & sName & "'!A1)") Then ThisWorkbook.Worksheets(sName).Delete
        Application.DisplayAlerts = True

        Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

        Do Until m >= lr
            With wsResult
                .Name = sName
                .DisplayRightToLeft = True
                sh.Rows("1:" & lRows).Copy .Rows(r)
                If b = False Then sh.Range("A" & r & ":G" & r + lRows - 1).Copy: .Range("A" & r).PasteSpecial Paste:=xlPasteColumnWidths: b = True
                .Range("D" & r + 12).Resize(16, 2).Value = ws.Range("A" & m).Resize(16, 2).Value
                .HPageBreaks.Add Before:=.Cells(r + lRows, 1)

                Application.PrintCommunication = False
                    With .PageSetup
                        .RightHeader = "&""Arial,Bold""&12&P"
                        .Orientation = xlPortrait
                        .FitToPagesWide = 1
                        .FitToPagesTall = False
                    End With
                Application.PrintCommunication = True
            End With
            m = m + 16: r = r + lRows
        Loop
    Application.ScreenUpdating = True
End Sub