VBA print macro to set page in specific manner - vba

I've been working on a print macro that I think is probably simple. I've tried recording a macro and have been researching for a few hours looking at other peoples code. What I would like is for the macro to:
1) select all cells in the active worksheet
2) set print scale to fit all columns to one page
3) print landscape mode
4) Open print preview (if possible)
5) If #4 is not possible then execute print job.
When I run my current code my excel worksheet gets split into tons of page (checker board style) and then I get an error code. Thanks for reading.
This is my current code:
Sub PrintNOPAsheet()'
' PrintNOPAsheet Macro
Cells.Select
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$A$1:$H$346"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.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)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.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
Application.PrintCommunication = True
Selection.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
End Sub
'

Here's what I usually use, then I made it to match your question. Within the With you can add as many of the properties you have from the recorded macro to suit your code.
Sub printIt()
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
Dim rng as Range
Dim printRange as String
Set rng = ws.Range("A1:J11")
''''For Dynamic Ranges'''''
With ws
Set rng = .Range(.Range("A1"),.Range("J11").End(xlDown))
End With
''''Range from User Highlighted Cells''''
Set rng = Selection
''''This method is not the best way''''
printRange = ws.Name & "!" & rng.Address
With ws.PageSetup
.PrintArea = printRange
.Zoom = False
.FitToPagesWide = 1 'Question 2
.Orientation = xlLandscape 'Question 3
End With
ws.PrintOut preview:=True 'Question 4
End Sub

Related

Export to PDF script only exports the last worksheet

I have an Excel VBA script that exports the contents of a worksheet to PDF. It worked fine with a single worksheet, but now I've been asked to have it include a second worksheet. However, using the script below now only includes the second worksheet and not the first. Can anyone advise why the first worksheet of the pair is not included?
Dim sheetsToPrint as Variant(1)
sheetsToPrint(0) = FirstWorksheet.Name
sheetsToPrint(1) = SecondWorksheet.Name
FirstWorksheet.PageSetup.PrintArea = Union(FirstWorksheet.Range("B2:I10"), FirstWorksheet.UsedRange).Address
With FirstWorksheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = -4
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
End With
SecondWorksheet.PageSetup.PrintArea = Union(secondPage.Range("B2:I10"), secondPage.UsedRange).Address
With SecondWorksheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = -4
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
End With
saveAndClose sheetsToPrint
The saveAndClose function is defined like this:
Private Sub saveAndClose(ByRef sheetsToPrint() As Variant)
Sheets(sheetsToPrint).Select
Dim primarySheetName As String
primarySheetName = CStr(sheetsToPrint(0))
Application.DisplayAlerts = False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=outputDirectoryPath & ":" & primarySheetName & ".pdf"
Sheets(sheetsToPrint).Delete
Application.DisplayAlerts = True
End Sub
This is part of a batch process, so I haven't copied all of my code, but this is the part that currently exports a PDF containing only the information from sheetsToPrint(1) but not sheetsToPrint(0). I've been banging my head on this all afternoon since as far as I can see, it's the same as every example on the internet of how to export multiple sheets to PDF.
Can anyone spot where I've gone wrong?
Can you set it up like this:
Dim sheetsToPrint As Sheets
Set sheetsToPrint = Sheets(Array("Blad1", "Blad2", "Blad3"))
And then use sheetsToPrint.select in the saveandclose sub

Excel vba defined footer

The folowing code is used to auto define the header/footer while plotting an excel worksheet to pdf.
Only thing that doesn't seem to work is the centerfooter function, it's supposed to give "active sheet name - defined date in dd-mm-yyyy format (value of cell Sheets("instellingen").Cells(22, 2) ), this results only in returning the date in format "mm-dd-yyyy" in the centerfooter, ignoring and not returning the activesheet name part.
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "Company name"
.RightHeader = ""
.LeftFooter = Sheets("instellingen").Cells(20, 2).Value
.CenterFooter = Activesheet.name & " - " & Sheets("instellingen").Cells(22, 2).Value
.RightFooter = "Pagina &P van de &N"
Thanks :)
Edit. (full macro)
Sub PlotPDF()
'
' PlotPDF Macro
'
' Sneltoets: Ctrl+Shift+P
'
Application.PrintCommunication = False
Application.Dialogs(xlDialogPrinterSetup).Show
With ActiveSheet.PageSetup
ActiveWindow.View = xlPageBreakPreview
ActiveSheet.PageSetup.PrintArea = "$A:$N"
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "Company name"
.RightHeader = ""
.LeftFooter = Sheets("instellingen").Cells(20, 2).Value
.CenterFooter = ActiveSheet.Name & " - " & Format(Sheets("instellingen").Cells(22, 2).Value, "dd-MM-yyyy")
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.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
Application.PrintCommunication = True
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
End Sub
Use the Format() function to format the date in .Cell(22, 2)
.CenterFooter = ActiveSheet.Name & " - " & Format(Sheets("instellingen").Cells(22, 2).Value, "dd-MM-yyyy")

Excel vba plot showing worksheet name + page number/adding title page in plot

I made the following script to automatic plot the active worksheet to a certain layout, in the right footer I would like to show the name of the active worksheet followed by the page number, 'edit: found the 'Activesheet.Name' formula, but still don't know how to add the page number (layout of page number: actual page numer/total amount of pages)
Example of a wanted right footer:
PartA - 1/12
Is it btw also possible to include a front page with just the name of the current worksheet, displayed in a big font in the center? Or is it needed to design the excel worksheet that way that the first page just contains one active cell with the title in the center?
Application.PrintCommunication = False
Application.Dialogs(xlDialogPrinterSetup).Show
With ActiveSheet.PageSetup
ActiveWindow.View = xlPageBreakPreview
ActiveSheet.PageSetup.PrintArea = "$A:$N"
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "PROJECT X"
.RightHeader = ""
.LeftFooter = Sheets("instellingen").Cells(20, 2).Value
.CenterFooter = Sheets("instellingen").Cells(22, 2).Value
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 0
.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
Application.PrintCommunication = True
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Thanks :)
When you are looking for a syntax, recording a macro while you do the manual steps can be very helpful.
I used Excel's built-in Page 1 of ? custom filter to get the syntax you are after. Manually, I went to Page Layout > Page Setup > Header / Footer > Footer > Page 1 of ?
.RightFooter = ActiveSheet.Name & " - " & "Page &P of &N"
You can really force a page number, since you don't know how many pages there are. So it's the same as setting it in regular Excel.
Try this Page &[Page] of &[Pages]
Regular format taken from https://support.office.com/en-us/article/Add-or-remove-page-numbers-57ebb99e-0cfc-408b-864a-c805b5040ae7
Side note, isn't using .PageSetup slow? I can't remember if they fixed it or not? There is a trick with using the print setup from the Excel4 Macros that was much faster.

Loop through .xml files stored in a folder and format it using VBA

So I have around 100 excel files saved as .xml in my folder and I have written a VBA code which formats the layout settings of each worksheet of all the workbooks(files) in my folder. But the problem is the code does not work on the last worksheet of all the workbooks, it works perfectly fine for the rest i.e. till the last worksheet of each workbook.
Here is the code:
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim sht As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xml"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
' added this line, loop through all worksheets in current wb
For Each sht In wb.Worksheets
'Change the layout
Application.PrintCommunication = False
With sht.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With sht.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.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
Next sht
'Save and Close Workbook
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Please let me know where I went wrong.
Thanks
Remove all the lines which say
Application.PrintCommunication = False
Application.PrintCommunication = True

Regularly printing to Adobe PDF from Excel, script to force PDFs to be saved to correct path

I am working on a series of XLS files in Excel. When I am done with them, I need to print them to PDF so that they can be transmitted to a party outside my firm.
I recorded a fairly basic macro to allow me to print these files with the same setting every time. Unfortunately, it is not doing everything I need it to do.
Basically, I want Adobe to ask me where the file should be saved when it's being printed. That is not taking place right now with my script. If I manually print and select the settings "Ask to replace existing PDF file" from the Printer Properties window in Excel, it always asks me where the file should be saved. My script is not catching this, however, and I'm not sure what I need to add.
I have a lot of files to go through (and this is a task that will recur) so the sooner I get this nailed down the better.
Is this something that I can address with my Excel macro, and if so, can anyone point me in the right direction?
Sub PrintToAdobeRedactions()
'
' PrintToAdobeRedactions Macro
' Print redacted worksheets to Adobe with correct settings every time.
'
' Keyboard Shortcut: Ctrl+e
'
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "[Tab]"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "Page [Page]"
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintSheetEnd
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlOverThenDown
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = False
.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
Application.PrintCommunication = True
ActiveWorkbook.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
End Sub
To SaveAs a PDF:
Sub SaveAsPDF()
Dim SaveName as String
SaveName = InputBox("Save As File Name?")
ThisWorkbook.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Application.ActiveWorkbook.Path & Application.PathSeparator & SaveName & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub