Shrink print to 1 page wide not working

I have some code which essentially prints sheets after doing some formatting.  I usually print to the Adobe PDF printer.  This all works well but it doesnt seem to want to stick to shrinking to 1 page wide (it can be as long as necessary).

Could anyone give me any pointers?

Sub print_all()
Dim startadd As Integer
Dim endadd As Integer
fn = ThisWorkbook.Name
Application.Dialogs(xlDialogPrinterSetup).Show
For Each ws In Sheets
sheetno = ws.Name
If Sheets(sheetno).Visible = True And Sheets(sheetno).Name <> "Start" And Sheets(sheetno).Name <> "Query" And Sheets(sheetno).Name <> "LookupPos" Then
printyn = MsgBox("Print " & sheetno & "?", vbYesNoCancel)
Select Case printyn
Case vbYes
fullsheetno = showname & " - " & sheetno & ".xls"

VariableToClipboard (fullsheetno)
startpa = False
endpa = False

For a = 1 To Sheets(sheetno).UsedRange.Columns.Count
If Columns(a).Hidden = False And startpa = False Then
startpa = True
startadd = a
End If
Next a

For B = Sheets(sheetno).UsedRange.Columns.Count To 1 Step -1
If Columns(a).Hidden = False And endpa = False Then
endpa = True
endadd = B
End If
Next B

endpa = False

ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PageSetup.PrintArea = "$" & ColumnLetter(startadd) & ":$" & ColumnLetter(endadd)
'With Sheets(sheetno).PageSetup
'.FitToPagesWide = 1
'End With
If Sheets(sheetno).Name = "Deads" Or Sheets(sheetno).Name = "IO" Then
With Sheets(sheetno).PageSetup
        .Orientation = xlPortrait
        .CenterHeader = Left(fn, Len(fn) - 4) & " - &A"
        .RightFooter = "Page &P of &N"
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PaperSize = xlPaperA4
End With
Sheets(sheetno).Activate
ActiveWindow.SelectedSheets.PrintOut Copies:=1
Else

With Sheets(sheetno).PageSetup
        .Orientation = xlLandscape
        .CenterHeader = showname & " - &A"
        .RightFooter = "Page &P of &N"
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PaperSize = xlPaperA4
End With
Sheets(sheetno).Activate
ActiveWindow.SelectedSheets.PrintOut Copies:=1

End If

Case vbNo
Case vbCancel
Exit Sub

End Select
End If
Next ws


End Sub

Public Sub VariableToClipboard(StringToCopy As String)
   Dim objData As Object
   Set objData = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

   With objData
      .SetText StringToCopy
      .PutInClipboard
   End With

End Sub

Function ColumnLetter(ColumnNumber As Integer) As String
  If ColumnNumber > 26 Then

    ' 1st character:  Subtract 1 to map the characters to 0-25,
    '                 but you don't have to remap back to 1-26
    '                 after the 'Int' operation since columns
    '                 1-26 have no prefix letter

    ' 2nd character:  Subtract 1 to map the characters to 0-25,
    '                 but then must remap back to 1-26 after
    '                 the 'Mod' operation by adding 1 back in
    '                 (included in the '65')

    ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & _
                   Chr(((ColumnNumber - 1) Mod 26) + 65)
  Else
    ' Columns A-Z
    ColumnLetter = Chr(ColumnNumber + 64)
  End If
End Function

Select allOpen in new window