Help on printing! VBA code not working.

dstepan

Board Regular
Joined
Apr 16, 2009
Messages
160
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)?

Rich (BB code):
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
 

Some videos you may like

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

Watch MrExcel Video

Forum statistics

Threads
1,123,152
Messages
5,600,017
Members
414,356
Latest member
death20

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top