I have a VBA code that works well, apart from the fact that i don't know how to exclude one sheet from saving to the PDF. I would like the exclude the sheet named 'Control' from being included in the export and save to PDF. Any ideas how or where i should add this?
Thanks
Sub CreatePDF()
Dim saveAsName As String
Dim WhereTo As String
Dim sFileName As String
Dim ws As Worksheet
Dim myrange
' Retrieve information from Control sheet
Sheets("Control").Activate
Range("C4").Activate
periodName = ActiveCell.Value
Range("C5").Activate
saveAsName = ActiveCell.Value
Range("C6").Activate
WhereTo = ActiveCell.Value
Set myrange = Worksheets("Control").Range("range_sheetProperties")
' Check if Stamp-field has any value at all
' if not, add the current date.
If Stamp = "" Then Stamp = Date
' Assemble the filename
sFileName = WhereTo & saveAsName & " (" & Format(CDate(Date), "DD-MMM-YYYY") & ").pdf"
' Format all sheets as landsape, autofit to 1 page and provide header
For Each ws In ActiveWorkbook.Worksheets
With ws.PageSetup
Application.PrintCommunication = False
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.CenterHorizontally = True
.ScaleWithDocHeaderFooter = False
.AlignMarginsHeaderFooter = False
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
Application.PrintCommunication = True
DisplayHeader = Application.VLookup(ws.Name, myrange, 2, False)
If Not IsError(DisplayHeader) Then
.LeftHeader = "&L &""Arial,Bold""&11&K00-048DIVA: " & DisplayHeader
Else: .LeftHeader = "&L &""Arial,Bold""&11&KFF0000WORKSHEET NOT DEFINED IN CONTROL SHEET "
End If
.CenterHeader = "&C &""Arial,Bold""&11&K00-048" & periodName
End With
Next
' Save the File as PDF
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
MsgBox "PDF document has been created and saved to : " & sFileName
' Make sure we open the Control sheet upon Exit
Sheets("Control").Activate
End Sub
You could hide the worksheet at the beginning of the code and then make it visible again at the end.
TESTED:
' Retrieve information from Control sheet
Sheets("Control").Visible = False
'YOUR PDF CREATION CODE
Sheets("Control").Visible = True
Sheets("Control").Activate
I ran into the same problem and just hid the sheet during the export function, then I brought it back... Here is the code:
'Hide the log sheet to exclude from export
ActiveWorkbook.Sheets("Log").Visible = xlSheetHidden
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FilePath + Today + "\" + Range("H2").Value _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
'Bring back the log sheet to allow for editing
ActiveWorkbook.Sheets("Log").Visible = xlSheetVisible
Related
For generating a report, I have create pdf with bellow approach.
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
fileName:=ThisWorkbook.path & "\rep.pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
In the ActiveSheet, there were specified Print Area, Witch contains a Table, so table's column filtered value have change programmatically, and need:
I want new face of the print area that reforms by changing filtering criteria; get appends at the end of initial pdf file quietly, without creating a new pdf file, in a new page section.
How can I do that?
I have installed ADOBE Acrobat Professional on my system and able to add appropriate references in VBA references.
You just need the "Acrobat" library.
One simple solution is to use the native ExportAsFixedFormat method to save each section as a separate PDF file first, e.g. "C:\temp\Part1.pdf" and "C:\temp\Part2.pdf"
Then use the InsertPages method in the Acrobat API as per example below:
Sub MergePDF()
Dim AcroApp As Acrobat.CAcroApp
Dim Part1Document As Acrobat.CAcroPDDoc
Dim Part2Document As Acrobat.CAcroPDDoc
Dim numPages As Integer
Set AcroApp = CreateObject("AcroExch.App")
Set Part1Document = CreateObject("AcroExch.PDDoc")
Set Part2Document = CreateObject("AcroExch.PDDoc")
Part1Document.Open ("C:\temp\Part1.pdf")
Part2Document.Open ("C:\temp\Part2.pdf")
' Insert the pages of Part2 after the end of Part1
numPages = Part1Document.GetNumPages()
If Part1Document.InsertPages(numPages - 1, Part2Document,
0, Part2Document.GetNumPages(), True) = False Then
MsgBox "Cannot insert pages"
End If
If Part1Document.Save(PDSaveFull, "C:\temp\MergedFile.pdf") = False Then
MsgBox "Cannot save the modified document"
End If
Part1Document.Close
Part2Document.Close
AcroApp.Exit
Set AcroApp = Nothing
Set Part1Document = Nothing
Set Part2Document = Nothing
MsgBox "Done"
End Sub
Reference: http://www.khk.net/wordpress/2009/03/04/adobe-acrobat-and-vba-an-introduction/
Adobe Developer Guide: http://www.adobe.com/devnet/acrobat/pdfs/iac_developer_guide.pdf
Adobe API Reference:
http://www.adobe.com/devnet/acrobat/pdfs/iac_api_reference.pdf
In the Solution, I provide there is no need of Acrobat Pro.
We suppose that we have a table which named: Table2.
We have also a help sheet(to store filtered tables) which is Hiden and named: Help.
Option Explicit
Sub print_to_pdf()
Dim sh As Long
Dim rg As Range
Dim Rng As Range
Dim rw As Range
Application.ScreenUpdating = False
For Each rw In Range("Table2[#All]").Rows
If rw.EntireRow.Hidden = False Then
If Rng Is Nothing Then Set Rng = rw
Set Rng = Union(rw, Rng)
End If
Next
Rng.Copy
With Sheets("help")
.Visible = True
sh = .Cells(Rows.Count, "A").End(xlUp).Row + 2
Set rg = Range("a3" & ":" & "a" & sh - 2)
.Activate
.Cells(sh, "A").Select
ActiveSheet.Paste
ActiveSheet.PageSetup.PrintArea = rg
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\rep.pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
.Visible = False
End With
Application.ScreenUpdating = True
MsgBox "Your PDF Has been Created with Success!!", vbInformation
End Sub
I am encountering a problem when I am attempting to print an Excel worksheet. I have a sub that calls two other subs, see below:
Sub AutoGen_NOW()
Application.Calculation = xlCalculationAutomatic
autoGen_refresh
autoGen_invoiceStageGen
End Sub
The subs called are
1. autoGen_refresh
2. autoGen_invoiceStageGen
The first sub called refreshes a workbook connection, while the second sub prints a worksheet that references the connection. My problem is, even though the printing sub occurs after the refresh sub, the printing sub prints the worksheet as it appeared before the refresh, not with the new data. When i look at the worksheet manually, after the print, it contains the new data.
Any help on this is much appreciated. I have added the two subs below:
Sub autoGen_refresh()
Dim LastAnnual As WorkbookConnection
Dim LastMonthly As WorkbookConnection
Dim oledbCn As OLEDBConnection
Set LastAnnual = ThisWorkbook.Connections("Staging_AnnualLastEntry")
Set LastMonthly = ThisWorkbook.Connections("Staging_MonthlyLastEntry")
'Refresh Annual Connection if Annual is selected - Refresh Monthly Connection if Monthly is selected
If MonthForm.OptionButton16.Value = True Then
LastAnnual.Refresh
Else
LastMonthly.Refresh
MonthlyTemp
MonthlyHide
End If
End Sub
Sub autoGen_invoiceStageGen()
Dim FolderPath As String
Dim sourceSheet As Worksheet 'This is the Worksheet where the data connection is
Dim i As Long
'Dim template worksheets
Dim annualRateWS As Worksheet
Dim annualPSFWS As Worksheet
Dim annualFlatWS As Worksheet
Dim monthlyRateWS As Worksheet
'Set template Worksheets
Set annualRateWS = Worksheets("00_ComRate_Template")
Set annualPSFWS = Worksheets("00_PSF_Template")
Set annualFlatWS = Worksheets("00_FlatAmount_Template")
Set monthlyRateWS = Worksheets("00_MONTHLYTEMPLATE")
'Set sourceSheet to Annual or Monthly table based on user input
Select Case MonthForm.OptionButton16.Value
Case "True"
Set sourceSheet = ThisWorkbook.Worksheets("Annual_InvoiceGen")
Case "False"
Set sourceSheet = ThisWorkbook.Worksheets("Monthly_InvoiceGen")
End Select
'Set path of directory all invoices are saved too
FolderPath = ("P:\Regis Profiles\00_MerchantDB\XX_TempDump\")
'Code used to stop screen flashing during macro operation -- This is set back to true after loop
Application.ScreenUpdating = False
'ANNUAL COMMISSION RATE - PDF GENERATION
If MonthForm.OptionButton16.Value = "True" And MonthForm.OptionButton7.Value = "True" Then
annualRateWS.Visible = True
annualRateWS.Activate
ThisWorkbook.Connections("Staging_AnnualLastEntry").Refresh
annualRateWS.Calculate
Workbook_BeforePrint (False)
'Application.Wait (Now + TimeValue("0:00:03"))
For i = 32 To 43 'This Code Hides All Calculation Years that are out of range*****
ActiveSheet.Rows(i).Hidden = (ActiveSheet.Cells(i, 5).Value = 0)
Next i
annualRateWS.Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FolderPath & ThisWorkbook.Worksheets("REF_InvoiceGen").Range("$B$2").Value & Format(Now(), "yyyymmddhhmmss"), Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
annualRateWS.Visible = False
End If
'ANNUAL COMMISSION PSF - PDF GENERATION
If MonthForm.OptionButton16.Value = True And MonthForm.OptionButton8.Value = "True" Then
annualPSFWS.Visible = True
annualPSFWS.Activate
ThisWorkbook.Connections("Staging_AnnualLastEntry").Refresh
annualPSFWS.Calculate
'Application.Wait (Now + TimeValue("0:00:03"))
annualPSFWS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FolderPath & ThisWorkbook.Worksheets("REF_InvoiceGen").Range("$B$2").Value & Format(Now(), "yyyymmddhhmmss"), Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
annualPSFWS.Visible = False
End If
'ANNUAL FLAT AMOUNT = PDF GENERATION
If MonthForm.OptionButton16.Value = True And MonthForm.OptionButton9.Value = "True" Then
annualFlatWS.Visible = True
annualFlatWS.Activate
ThisWorkbook.Connections("Staging_AnnualLastEntry").Refresh
annualFlatWS.Calculate
'Application.Wait (Now + TimeValue("0:00:03"))
annualFlatWS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FolderPath & ThisWorkbook.Worksheets("REF_InvoiceGen").Range("$B$2").Value & Format(Now(), "yyyymmddhhmmss"), Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
annualFlatWS.Visible = False
End If
'MONTHLY COMMISSION RATE - PDF GENERATION
If MonthForm.OptionButton16.Value = "False" And MonthForm.OptionButton7.Value = "True" Then
monthlyRateWS.Visible = True
monthlyRateWS.Activate
monthlyRateWS.Calculate
MonthlyTemp
MonthlyHide
'Application.Wait (Now + TimeValue("0:00:03"))
monthlyRateWS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FolderPath & ThisWorkbook.Worksheets("REF_InvoiceGen").Range("$B$2").Value & Format(Now(), "yyyymmddhhmmss"), Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
monthlyRateWS.Visible = False
End If
sourceSheet.Visible = False
'Code used to set screen updating BACK TO True
Application.ScreenUpdating = True
End Sub
Tim Williams solved the problem. Background refresh was enabled on the connections. After disabling this, everything worked properly.
I am no VBA guru, but capable enough to stitch together the below code. It essentially formats a Invoice to hide any empty rows (populated with vlookups, but no value returns ""), set to 1 page portrait and export to PDF.
My issue is:
The code is taking way to long to run from start to finish.
Below is the VBA code I want to optimize and speed up.
Sub Save_Quote_As_PDF()
Application.ScreenUpdating = False
Dim a As Long
For a = 1 To ActiveSheet.Shapes.Count
On Error Resume Next
With ActiveSheet.Shapes.Item(a)
.Placement = xlMoveAndSize
.PrintObject = True
End With
Next a
On Error GoTo 0
ActiveSheet.Range("DCANUMBER").SpecialCells(4).EntireRow.Hidden = True
Dim PdfFilename As Variant
PdfFilename = Application.GetSaveAsFilename( _
InitialFileName:=ActiveWorkbook.Path & "\" & ActiveSheet.Range("N2").Value, _
FileFilter:="PDF, *.pdf", _
Title:="Save As PDF")
If PdfFilename <> False Then
With ActiveSheet.PageSetup
.Orientation = xlPortrait
.PrintArea = "$A$1:$K$78"
.PrintTitleRows = ActiveSheet.Rows(19).Address
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
End With
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=PdfFilename, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End If
ActiveSheet.Range("DCANUMBER").SpecialCells(4).EntireRow.Hidden = False
Application.ScreenUpdating = True
End Sub
To hide the blank rows:
Dim ws As Worksheet
Set ws = ActiveSheet ' ActiveSheet is of type Object so using type Worksheet is a tiny bit faster
Dim row As Range ' again, specifying the type makes it a tiny bit faster
For Each row In ws.UsedRange.Rows ' .UsedRange to limit the range to only the used range
If row.Find("*") Is Nothing Then
row.EntireRow.Hidden = True
End If
Next
I don't think that hiding the rows is the slowest part of your code. You should time your code to see what parts are the slowest:
Dim start As Single
start = Timer
' part of the code
Debug.Print CDbl(Timer - start), "part 1" ' CDbl to avoid scientific notation
start = Timer ' remember to reset the start time
' another part of the code
Debug.Print CDbl(Timer - start), "part 2"
The below code generates a PDF file from a dynamic array of sheets. The second code sets the print area and print titles on the individual sheets of interest. Some of the sheets have multiple, discontinuous regions set to print.
Worksheets(sSheetsArray).Select
sFilename = "L:\[FilePath]" & Format(Now, "DD-MMM-YY-HH-MM") & "2.pdf"
Debug.Print sFilename
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=sFilename, _
Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Sub to set print areas etc.
Sub SetWorksheetPrintArea(ws As Worksheet, sPrintAreas As String, sTitleRange As String, bLandscape As Boolean)
With ws.PageSetup
.PrintArea = sPrintAreas
.PrintTitleRows = sTitleRange
If bLandscape Then .Orientation = xlLandscape Else .Orientation = xlPortrait
.Zoom = False
.FitToPagesWide = 1
End With
End Sub
This works, however, I need to have one sheet produce pages side by side in the PDF. This should be similar to the way it would be presented on paper if set to booklet printing. Does anyone know how this could be done without re-arranging the layout of the sheet?
The task here is two fold (the first part already works though).
Task 1: Copy a sheet that's been selected from a combo box into a new document.
Task 2: Copy a specific sheet from the original document and add it to the new document that was created above.
So far I've got this: (but the second task doesn't work)
Sub Extract()
Dim wbkOriginal As Workbook
Set wbkOriginal = ActiveWorkbook
'sets site and engineer details into the estate page that is being extracted
Worksheets(FrontPage.CmbSheet.Value).Range("B3").Value = Worksheets("front page").Range("E6")
Worksheets(FrontPage.CmbSheet.Value).Range("D3").Value = Worksheets("front page").Range("N6")
Worksheets(FrontPage.CmbSheet.Value).Range("F3").Value = Worksheets("front page").Range("K6")
Worksheets(FrontPage.CmbSheet.Value).Range("B4").Value = Worksheets("front page").Range("F8")
Worksheets(FrontPage.CmbSheet.Value).Range("D4").Value = Worksheets("front page").Range("K8")
' copies sheet name from combo box into new document, saves it with site name and current date
' into C:\Temp\ folder for ease of access
With ActiveWorkbook.Sheets(FrontPage.CmbSheet.Value)
.Copy
ActiveWorkbook.SaveAs _
"C:\temp\" _
& .Cells(3, 2).Text _
& " " _
& Format(Now(), "DD-MM-YY") _
& ".xlsm", _
xlOpenXMLWorkbookMacroEnabled, , , , False
End With
Dim wbkExtracted As Workbook
Set wbkExtracted = ActiveWorkbook
Workbooks(wbkOriginal.Name).Sheets(DOCUMENTS).Copy _
After:=Workbooks(wbkExtracted.Name).Sheets(wbkExtracted.Name).Sheets.Count
'code to close the original workbook to prevent accidental changes etc
'Application.DisplayAlerts = False
'wbkOriginal.Close
'Application.DisplayAlerts = True
End Sub
I'm hoping one of you clever folks out there can tell me what I'm doing wrong :)
I think I know the problem you are running into. (Maybe) If you are working with a new instance of excel you need to save it then reopen it. It must have something to do with the object model. I had to do this not too long ago. Here is a snippet of the code I used.
Set appXL = New Excel.application
appXL.Workbooks.Add
Set wbThat = appXL.ActiveWorkbook
wbThat.application.DisplayAlerts = False
wbThat.SaveAs Filename:=strFilePath & "\" & strFileName
'This code needed to allow the copy function to work
wbThat.Close savechanges:=True
Set wbThat = Nothing
Set wbThat = application.Workbooks.Open(strFilePath & "\" & strFileName)
appXL.Quit
Set appXL = Nothing
'Copy Help page from this workbook to the report
wbThis.Sheets("Help").Copy after:=wbThat.Sheets(wbThat.Sheets.Count)
Sub Full_Extract()
Dim wbkOriginal As Workbook
Set wbkOriginal = ActiveWorkbook
'sets site and engineer details into the estate page that is being extracted
Worksheets(Sheet1.CmbSheet.Value).Range("B3").Value = Worksheets("front page").Range("E6")
Worksheets(Sheet1.CmbSheet.Value).Range("D3").Value = Worksheets("front page").Range("N6")
Worksheets(Sheet1.CmbSheet.Value).Range("F3").Value = Worksheets("front page").Range("K6")
Worksheets(Sheet1.CmbSheet.Value).Range("B4").Value = Worksheets("front page").Range("F8")
Worksheets(Sheet1.CmbSheet.Value).Range("D4").Value = Worksheets("front page").Range("K8")
' copies sheet name from combo box into new document, saves it with site name and current date
' into C:\Temp\ folder for ease of access
With ActiveWorkbook.Sheets(Array((Sheet1.CmbSheet.Value), "Z-MISC"))
.Copy
ActiveWorkbook.SaveAs _
"C:\temp\" _
& ActiveWorkbook.Sheets(Sheet1.CmbSheet.Value).Cells(3, 2).Text _
& " " _
& Format(Now(), "DD-MM-YY") _
& ".xlsm", _
xlOpenXMLWorkbookMacroEnabled, , , , False
End With
'code to close the original workbook to prevent accidental changes etc
Application.DisplayAlerts = False
wbkOriginal.Close
Application.DisplayAlerts = True
End Sub