VBA to select the Width and Height to 1 page , Orientation as Landscape and Paper Size to Legal for multiple xlsx files in a folder

JBMS · Apr 9th 2021

[xpost][/xpost]

Hi Team,

Need assistance for the below query.

VBA to select the Width and Height to 1 page, Orientation as Landscape and Paper Size to Legal for multiple xlsx files in a folder

rollis13 · Apr 9th 2021

Just to add missing cross-post link: LINK

**royUK** · Apr 9th 2021

Try this. I've left all the options that you can change in the PageSetup for reference. I haven't checked it so let me know if it needs any amendments

Code

Option Explicit


Sub LoopFiles()
    Dim oWb As Workbook
    Dim sFldr As String, sFilName As String
    Dim fDialog As Object
    
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    If fDialog.Show = -1 Then
        sFldr = fDialog.SelectedItems(1)
        Else: MsgBox "User cancelled selection"
        Exit Sub
    End If
    
    sFilName = Dir(sFldr & "\*.xls*")
    Do While sFilName > ""
        Set oWb = Workbooks.Open(sFldr & "\" & sFilName)
        oWb.Sheet(1).Select
        PageSetUp oWb.Sheet(1)
        Selection.ColumnWidth = 10
        oWb.Close SaveChanges:=False ''///Close opened worbook w/o saving, change as needed
        sFilName = Dir()
    Loop
    
    MsgBox "All files updated", vbInformation, "Success"
    
End Sub
Sub PageSetUp(sh As Worksheet)
    
    With sh.PageSetUp
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    
    sh.PageSetUp.PrintArea = ""
    
    With sh.PageSetUp
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.708661417322835)
        .RightMargin = Application.InchesToPoints(0.708661417322835)
        .TopMargin = Application.InchesToPoints(0.748031496062992)
        .BottomMargin = Application.InchesToPoints(0.748031496062992)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLegal
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    
    
    
End Sub

Display More

JBMS · Apr 9th 2021

Hi,

Thank you for your quick reply. Appreciate your help. Need the VBA to apply the changes to all the xlsx files in a folder. So the macro/VBA should change the sheet width and height to 1 Page. Orientation as "Landscape" and Paper Size to "Legal". Request to extend your support.

Thank you.

**royUK** · Apr 9th 2021

Have you tried what I posted?

JBMS · Apr 9th 2021

Hi,

Yes, it is giving an error pop up message as "Run-time error '438':
"Object doesn't support this property or method.

1) Just to be more specific. All the files in the folder are in XLSX format and the data is only in sheet 1 of the workbook.

**royUK** · Apr 9th 2021

I've edited the code slightly

Code

Option Explicit


Sub LoopFiles()
    Dim oWb As Workbook
    Dim sFldr As String, sFilName As String
    Dim fDialog As Object
    
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    If fDialog.Show = -1 Then
        sFldr = fDialog.SelectedItems(1)
        Else: MsgBox "User cancelled selection"
        Exit Sub
    End If
    
    sFilName = Dir(sFldr & "\*.xls*")
    Do While sFilName > ""
        Set oWb = Workbooks.Open(sFldr & "\" & sFilName)      
      PageSetUp
        oWb.Close SaveChanges:=False ''///Close opened worbook w/o saving, change as needed
        sFilName = Dir()
    Loop
    
    MsgBox "All files updated", vbInformation, "Success"
    
End Sub
Sub PageSetUp()
    
    With ActiveSheet.PageSetUp
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    
    ActiveSheet.PageSetUp.PrintArea = ""
    
    With ActiveSheet.PageSetUp
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.708661417322835)
        .RightMargin = Application.InchesToPoints(0.708661417322835)
        .TopMargin = Application.InchesToPoints(0.748031496062992)
        .BottomMargin = Application.InchesToPoints(0.748031496062992)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLegal
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    
    
    
End Sub

Display More

JBMS · Apr 9th 2021

Hi,

The above code is running, however, the changes are not made to the files in the folder.

**royUK** · Apr 9th 2021

I forgot to change on inee.

Change one line

Code

oWb.Close SaveChanges:=False

should be

Code

oWb.Close SaveChanges:=True

JBMS · Apr 9th 2021

Hi,

Thank you it is working now. However, it is taking a lot of time. Please advise.

JBMS · Apr 9th 2021

Hi,

Please suggest a way to make the VBA run faster. The provided code was working really well, however taking little time for the excution. Your help is appreciated.

VBA to select the Width and Height to 1 page , Orientation as Landscape and Paper Size to Legal for multiple xlsx files in a folder

Participate now!

Share