Set up print area and avoid printing blank pages (VBA)

[feni1388]

Hello...

I'm using the vba code below to set up print area and avoid printing blank pages, but it doesn't seem to work.
Can someone please help?

Column A to S is fixed but the row can sometimes short or long. When it's short, all the blank pages got printed too.

Dim rng As Range
Dim k As Range
On Error Resume Next
k = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ActiveSheet.Range("A1:S" & k)

With ActiveSheet.PageSetup
.PrintArea = rng.Address
.Orientation = xlLandscape
End With

Application.ScreenUpdating = True

 

[MikeVol]

Hello @feni1388.
Try next code:

    Dim LR          As Long
    Dim ws          As Worksheet: Set ws = ActiveSheet

    With ws
        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        .PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(LR, "S")).Address
        .PageSetup.Orientation = xlLandscape
    End With

Good luck.

 

[jolivanes]

Re: "When it's short, all the blank pages got printed too"

This sounds like the code does not set the print range to what you expect it to be.

Following is your code from Post #1 with one line added to it.
Let us know what the result in that Message Box is please.

Dim rng As Range
Dim k As Range
On Error Resume Next
k = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ActiveSheet.Range("A1:S" & k)

With ActiveSheet.PageSetup
.PrintArea = rng.Address
.Orientation = xlLandscape
MsgBox Cells(k, 1).Address    <----- Insert this line
End With

Oh, maybe get used to putting your code between code tags.

 

[feni1388]

@jolivanes , @MikeVol

I tried both of your code, but none of it works.....

 

[feni1388]

I'm not sure but perhaps because I copied this sheet from another sheet that has formula in it but blank.
so when I selected the rows, it copied those with formula in it too.
I tried limiting the rows selected only with those with value in it and ignore the ones with formula, but it failed too.

Range("A1:S" & Range("G" & Rows.Count).End(xlUp).Row).Select

 

[MikeVol]

Perhaps not all rows in your first column (A) are filled with data. Look in the other column for the last completed row of data. Try to play with:

LR = .Range("A" & .Rows.Count).End(xlUp).Row

To find the last completed row of data. For me, the code I provided works without errors or problems.

 

[jolivanes]

You did not answer the question in Post #3.


instead of this

k = Cells(Rows.Count, 1).End(xlUp).Row

use this

k = Columns(1).Find("*", ,xlValues , , xlByRows, xlPrevious).Row

 

[feni1388]

You did not answer the question in Post #3.


instead of this

k = Cells(Rows.Count, 1).End(xlUp).Row

use this

k = Columns(1).Find("*", ,xlValues , , xlByRows, xlPrevious).Row

Sorry, I thought I replied already.
The previous code didn't work and I tried the one that you suggested above and didn't work either.
Thank you for your suggestion to use the code tags. I didn't know that.

 

[feni1388]

Perhaps not all rows in your first column (A) are filled with data. Look in the other column for the last completed row of data. Try to play with:

LR = .Range("A" & .Rows.Count).End(xlUp).Row

To find the last completed row of data. For me, the code I provided works without errors or problems.

This is my code.
I tried playing with the code as you suggested but it didn't work either. I really don't understand the cause.

Option Explicit

Sub AllFiles()

      
    Dim folderPath As String
    Dim filename As String
    Dim wb As Workbook
    Dim SumRg As Range
    
    
 
    folderPath = "\\obcsvr\Share\Account\customer\" 'change to suit
    
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
    
    filename = Dir(folderPath & "*.xlsx")
    Application.ScreenUpdating = False
    Do While filename <> ""
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    
      
    Set wb = Workbooks.Open(folderPath & filename)
    
      
        
        'Call a subroutine here to operate on the just-opened workbook
        
         Range("D1").Value = filename
    
         Columns("A:AJ").Select
         Selection.Copy
         ThisWorkbook.Activate
         Sheets("Sheet1").Select
         Columns("A:AJ").Select
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
         Application.CutCopyMode = False
        
                  
         Set SumRg = Range("Z4", Range("Z" & Rows.Count).End(xlUp))
         Range("Z" & Rows.Count).End(xlUp).Offset(1, 0) = "=Sum(" & SumRg.Address & ")"
        
         Sheets("Print").Select
         Cells.Select
         Selection.Clear
         ActiveSheet.PageSetup.PrintArea = ""
        
        
         Sheets("template").Activate
         Columns("A:S").Select
         Selection.Copy
         Sheets("Print").Select
        
         Columns("A:S").Select
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
         Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
         Application.CutCopyMode = False
        
         Dim i As Integer
         Dim j As Integer

          For i = 1 To 1000

          j = InStr(1, Cells(i, 15), "Other", vbTextCompare)

          If j = 1 Then
          'Cells(i, 1).EntireRow.Copy
          Cells(i + 1, 1).EntireRow.Insert
          Application.CutCopyMode = False


        Cells(i + 1, 3).Value = "Total"
        Cells(i + 1, 7).Value = Cells(i, 16)
        Cells(i + 1, 5).Value = Cells(i, 17)

        i = i + 1

        Else
        End If

        Next i

        
        
        

          ThisWorkbook.Sheets("Print").Activate
          ActiveSheet.PageSetup.PrintArea = ""
          
        Dim LR As Long
        Dim ws As Worksheet: Set ws = ActiveSheet

       With ws
        LR = .Range("G" & .Rows.Count).End(xlUp).Row
        .PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(LR, "N")).Address
        .PageSetup.Orientation = xlLandscape
        .PageSetup.PrintTitleRows = "$2:$2" --> I just added this, but even without it, it's the same
       End With
        
      
                    
          'ThisWorkbook.Sheets("Print").PrintOut
          wb.SaveAs filename:="\\obcsvr\Share\Docs\Cust\Order\west\" & Range("S1").Value & ".xlsx"
          wb.Close SaveChanges:=False
          Application.DisplayAlerts = True
          Application.AskToUpdateLinks = True
        
        filename = Dir
    Loop
  Application.ScreenUpdating = True
 
  MsgBox "Printed"

End Sub

 

[jolivanes]

Read the 3rd and 4th line in Post #3 again.