Help cleaning up VBA code that copies/pastes rows and sets print areas

[cvrband]

I have some VBA that I cobbled together over time with other's assistance and would like to make it more streamlined. The code copies formulas and formatting in the last used row and pastes it in the following rows based on user input. The code currently works but seems cumbersome and slow. The array formula in the middle has helped tremendously, but believe that the rest of the code could be combined/streamlined. If possible, I would like the following:

• Move the copy/paste section for "Sheet 1" into the current array or something similar to that array so that "Sheet 1" does not need to be ".select" (notice that the "Sheet 1" copy/paste uses the 'NoPt' variant while the array section uses the 'NoTs' variant to dictate the number of rows to copy down)
• If possible make an array formula to set the print areas of the given pages after the copy/paste commands are completed. Again, to keep from having to activate or '.select' each sheet to change the print area. (Some of the sheets in the array section do not get printed and that is why they are not listed in the print area section of the code)

Here is the current code:

Sub FormulaCopy()
Dim NoPt As Variant
Dim NoTs As Variant
Dim r As Range, Arr
    'Turn off AutoCalculate
    Application.Calculation = xlManual
    'Turn off screen updating
    Application.ScreenUpdating = False


    NoPt = InputBox("Enter number of points required.", "", "")
    NoTs = InputBox("Enter number of tokens required.", "", "")


        Do Until NoPt <> ""
        Loop
    
        Sheets("Sheet 1").Select
            For i = 1 To NoPt
        'Find the last row of equations
                FinalRow = Sheets("Survey Data").Range("A65536").End(xlUp).Row
        'Copy last row of formulas
                Range("A" & FinalRow & ":T" & FinalRow).Copy
        'Select cell of next empy row
                NextRow = Range("A65536").End(xlUp).Row + 1
                Range("A" & NextRow).Select
                'Past row into next empy row
                ActiveSheet.Paste
            Next i
            NewLastRow = ActiveSheet.Range("A65536").End(xlUp).Row
            Range("A1:S" & NewLastRow).Select
            ActiveSheet.PageSetup.PrintArea = ("A1:S" & NewLastRow)
    
    Do Until NoTs <> ""
    Loop


        Arr = Array("Sheet 2", "AD", "Sheet 3", "P", "Sheet 4", "CA", "Sheet 5", "X", "Sheet 6", "M", "Sheet 7", "AZ")
    
        For i = LBound(Arr) To UBound(Arr) Step 2
            With Sheets(Arr(i))
                rr = .Range("A" & Rows.Count).End(xlUp).Row
                Set r = .Range(.Cells(rr, "A"), .Cells(rr, Arr(i + 1)))
                r.Copy .Range(.Cells(r.Row + 1, "A"), .Cells(r.Row + NoTs, Arr(i + 1)))
                Application.CutCopyMode = False
            End With
        Next


        Sheets("Sheet 2").Select
            NewLastRow = ActiveSheet.Range("A65536").End(xlUp).Row
            Range("A1:AD" & NewLastRow).Select
            ActiveSheet.PageSetup.PrintArea = ("A1:AD" & NewLastRow)
            Range("A1").Select
        Sheets("Sheet 3").Select
            NewLastRow = ActiveSheet.Range("A65536").End(xlUp).Row
            Range("A1:P" & NewLastRow).Select
            ActiveSheet.PageSetup.PrintArea = ("A1:P" & NewLastRow)
            Range("A1").Select
    'Unhide Sheet 4
        Sheets("Sheet 4").Visible = True
        Sheets("Sheet 4").Select
            NewLastRow = ActiveSheet.Range("A65536").End(xlUp).Row
            Range("A1:CA" & NewLastRow).Select
            ActiveSheet.PageSetup.PrintArea = ("A1:CA" & NewLastRow)
            Range("A1").Select
        'Hide Sheet 4
        Sheets("Sheet 4").Visible = False
        Sheets("Sheet 7").Select
            NewLastRow = ActiveSheet.Range("A65536").End(xlUp).Row
            Range("A1:AJ" & NewLastRow).Select
            ActiveSheet.PageSetup.PrintArea = ("A1:AJ" & NewLastRow)
            Range("A1").Select
    Application.CutCopyMode = False
    ' Turn on Screen Updating
    Application.ScreenUpdating = True
    ' Turn on AutoCalculate
    MsgBox "Insertion Complete!"
End Sub

Thank you in advance!

 

[Yongle]

Last Row
A long time ago, sheets had 65,536 rows, but now contain over 1million. Safer to use code that can handle any number of rows.

Range("A65536").End(xlUp)

Instead use use

Range([COLOR=#ff0000]"A" & Rows.Count)[/COLOR].End(xlUp)

Avoid selecting
Selecting anything slows things down and there is usually no requirement to select objects in VBA

        Sheets("Sheet 2").Select
            NewLastRow = ActiveSheet.Range("A65536").End(xlUp).Row
            Range("A1:AD" & NewLastRow).Select
            ActiveSheet.PageSetup.PrintArea = ("A1:AD" & NewLastRow)
            Range("A1").Select

can be replaced with

        With Sheets("Sheet 2")
            NewLastRow = .Range([COLOR=#ff0000]"A" & Rows.Count[/COLOR]).End(xlUp).Row
            .PageSetup.PrintArea = ("A1:AD" & NewLastRow)
        End With

Avoid repeating code by creating another sub to set print areas

Private Sub SetPrintArea(aSheet As Worksheet, aRangeString As String)
    Dim NewLastRow As Long
    With aSheet
        NewLastRow = .Range("A" & Rows.Count).End(xlUp).Row
        .PageSetup.PrintArea = (aRangeString & NewLastRow)
    End With
End Sub

... and call like this

    Call SetPrintArea(Sheets("Sheet 2"), "A1:AD")
    Call SetPrintArea(Sheets("Sheet 3"), "A1:AD")
    Call SetPrintArea(Sheets("Sheet 4"), "A1:CA")
    Call SetPrintArea(Sheets("Sheet 7"), "A1:AJ")

note
- there is no requirement to Unhide and Hide Sheet 4 if it is not being selected

 

[cvrband]

Thank you, Yongle. Your directions and comments were very helpful. I was able to update my code accordingly and everything works great!