Printing filtered data and stopping printing blank pages and fitting all columns in one page using vba

 Sub justprint()

Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If









'let us first delete anysheet containing name like Canada and create sheets named as Canada

 With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
   
Dim wks, newsheet As Worksheet


For Each wks In Application.Worksheets
        If wks.name = "Canada" Then wks.Delete
    Next



 Dim cntsheets As Long
 
     cntsheets = Application.Sheets.Count
    Set newsheet = Application.Worksheets.Add(After:=Worksheets(cntsheets))
    newsheet.name = "Canada"

   

'Now creating sheets is done ,let us go back the data sheet and remove any filter from the sheet
'creating the directory for pdf files

Dim output_file As String, ws_count, i As Integer
Dim path, folder As String
path = "C:\Users\allso\Desktop\excel_to_pdf_2"
folder = dir(path, vbDirectory)
If folder = vbNullString Then

       
                VBA.FileSystem.MkDir (path)
          

    Else

    

    End If
    
Sheets("Sheet1").Select

Dim mynetwork As Object


Dim dataforfilter As String
Dim strtime As String
'set current default printer
Set mynetwork = CreateObject("WScript.network")
mynetwork.setdefaultprinter "Adobe PDF"
Dim objAccess As Object
Set objAccess = CreateObject("Access.Application")
Dim prtLoop As Object
'get current default printer
Set prtLoop = objAccess.Printer
'now we can access the printquality supported by the default printer by using prtloop.printquality

dataforfilter = Replace(ActiveSheet.Range("A1").CurrentRegion.Address, "$", "")
'MsgBox (dataforfilter)
ActiveSheet.Range(dataforfilter).AutoFilter Field:=2, Criteria1:="Canada", Operator:=xlFilterValues
'ActiveSheet.Range(dataforfilter).AutoFilter Field:=4, Criteria1:="=Yes", Operator:=xlFilterValues
'sort the filtered range by the column gross sales
dataforfilter = Replace(ActiveSheet.Range("A1").CurrentRegion.Address, "$", "")
'MsgBox (dataforfilter)
Range(dataforfilter).Sort key1:=[h2], Order1:=xlDescending, Header:=xlYes
ActiveSheet.Range("A1").CurrentRegion.Select
Selection.Copy

Sheets("Canada").Select
'Range("A1").PasteSpecial xlPasteValues

Range("A1").PasteSpecial xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
        
'autofitting the columns
ActiveSheet.Cells.Columns.AutoFit
'removing the borders
'changing the font
 With ActiveSheet.Cells.Font
 
        .name = "Georgia Pro"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

ActiveSheet.Cells.Borders.LineStyle = xlLineStyleNone

'now saving the sheet as pdf


If Format(CDate(Now), "am/pm") = "am" Then
strtime = Format(Now(), "yyyymmdd\_hhmmss") & " AM"
Else
strtime = Format(Now(), "yyyymmdd\_hhmmss") & " PM"
End If

output_file = path & "\" & Left(ThisWorkbook.name, Len(ThisWorkbook.name) - 5) & "." & ActiveSheet.name & "." & strtime & ".pdf"

'setting the page setup

'ActiveSheet.PageSetup.CenterHeader = "&B&14" & "Financial Data for " & uniquedatafinal(length) & ""

'&""Courier New""

'determine it is am or pm

If Format(CDate(Now), "am/pm") = "am" Then


ActiveSheet.PageSetup.CenterHeader = "&B&14&""Arial Narrow""&K00B0F0" & "Financial Data for " & "Canada" & " on " & "&D" & "," & "&T" & " AM"
Else
ActiveSheet.PageSetup.CenterHeader = "&B&14&""Arial Narrow""&K00B0F0" & "Financial Data for " & "Canada" & " on " & "&D" & "," & "&T" & " PM"

End If

'this is for setting the right footer of print which will print as Page (number of current page) of Total Pages
ActiveSheet.PageSetup.RightFooter = "&B&10&""Arial Narrow""&K00B0F0" & "Page &P of &N"

'change activeprinter to a choice of mine

'to set printarea manually we have to calculate the printarea using this lastrow
Dim lastrow As Long

lastrow = Application.WorksheetFunction.Subtotal(3, Range("P:P"))

'this commented out section works best with portrait printing

With ActiveSheet.PageSetup
.CenterHorizontally = True
'.CenterVertically = True
.BottomMargin = 50
.TopMargin = 50
.RightMargin = 10
.LeftMargin = 10
'.Zoom = 50
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintTitleRows = ActiveSheet.Rows(1).Address
.Orientation = xlPortrait
.PrintQuality = prtLoop.PrintQuality
.PrintArea = "A1:P" & lastrow

End With
'MsgBox (ActiveSheet.PageSetup.PrintArea.Address)
'ActiveSheet.PrintPreview
'this section works best for landscape printing
'With ersheet.PageSetup
''for setting portrait or landscape
'.Orientation = xlLandscape
''these next two line will fit all columns in one page
'.FitToPagesWide = 1
'.FitToPagesTall = 1
''this line is responsible for continuing one fixed row on several print pages ,it is similar as excel freeze pane
'.PrintTitleRows = ersheet.Rows(1).Address
'End With
ActiveWorkbook.ActiveSheet.ExportAsFixedFormat xlTypePDF, output_file, xlQualityStandard, openafterpublish:=False
    
    
Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If



If ActiveSheet.AutoFilterMode Then

     ActiveSheet.AutoFilterMode = False

End If

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With

End Sub

Source:https://stackoverflow.com/questions/25741049/how-to-set-fit-all-columns-on-one-page-in-print-tab

Source:https://stackoverflow.com/questions/17285897/row-count-on-the-filtered-data