Help on printing! VBA code not working.

[dstepan]

Well I tried to work this one out on my own but something is wrong. After running the code, pages started printing. I should get about 46-47 sheets, but the page number in footer shows 1/195 pages.

I have a workbook with 44 sheets.
Sheet one is my data sheet and has a large amount of data. I don't want this sheet to printout.
The other sheets will basically printout on 1 page with the exception of about 2 which will print out on 2 pages.
Therefore, I want my code to print Sheets 2:44. One page wide by maximum of 2 pages long.
Is it an easy fix to the code I found for printing - see bottom of code below?
If a worksheet is 2 pages long can I get it to print titles to the second page rows(1:3)?

Sub copy_data()

  Dim lc As Long, c As Long, lr As Long
  Dim wsAct As Worksheet, wsNew As Worksheet
  Dim fName As String
  fName = "C:\users\kliadis.MY-CAP\Documents\DS\Budget vs Average" & Format(Now, "   mmddyy - hhmm") & ".xlsm"
ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
  Set wsAct = ActiveSheet
  With wsAct
    lc = .Cells(2, .Columns.Count).End(xlToLeft).Column
    lr = .Cells.Find(What:="*", After:=.Cells(1), LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, SearchFormat:=False).Row
    Application.ScreenUpdating = False
    For c = 6 To lc Step 4
      Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count))
      .Cells(1, c).Resize(lr, 4).Copy
      wsNew.Range("f1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      wsNew.Range("f1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      .Cells(1, 1).Resize(lr, 5).Copy
      wsNew.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      wsNew.Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Next c
    
Application.ScreenUpdating = False
    Dim LastRow As Long, x As Long, rng As Range, counter As Long, wsht As Worksheet


    For Each wsht In ActiveWorkbook.Worksheets
        If wsht.Name <> "Sheet1" Then


            With wsht
                LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                For x = LastRow To 2 Step -1
                    counter = 0
                    If WorksheetFunction.CountA(.Range("A" & x & ":d" & x)) = 0 Then
                        For Each rng In .Range("f" & x & ":H" & x)
                            If rng = 0 Or rng = "" Then
                                counter = counter + 1
                            End If
                            If counter = 3 Then .Rows(x).EntireRow.Delete
                        Next rng
                    End If
                Next x
            End With
        End If
    Next
    Application.ScreenUpdating = True
Application.ScreenUpdating = False
    Dim i As Long
    For i = 2 To Worksheets.Count
        Sheets(i).Activate
        Cells.EntireColumn.AutoFit
        Columns("A:d").ColumnWidth = 1.5
    Next i
    Sheets(1).Select
    Application.ScreenUpdating = True
Dim WB As Workbook
For Each WB In Workbooks
    WB.Save
Next WB
Application.StatusBar = "All Workbooks Saved."
    
For Each ws In Worksheets
    If ws.Name <> "Sheet1" Then _
          ws.Select False
Next ws
ActiveWindow.SelectedSheets.PrintOut
End With
End Sub