So I am trying to print an Excel sheet. So far I got most of the stuff set up, but I can't get the line number nor the column letter working.
I tried a bunch of stuff like LineNumbering, PrintTitleColumns, but I think that's not what I am actually looking for.
Here's my code:
Sub PrintToPDF()
' Saves active sheet as PDF file.
Dim Name As String
Dim wkPrint As Worksheet
FileNameArray = Split(ThisWorkbook.Name, ".")
Name = ThisWorkbook.Path & "\" & Format(Now(), "yyyy-mm-dd") & "_" & FileNameArray(0) & ".pdf"
Set wkPrint = ThisWorkbook.Worksheets("Dokumentation")
'On Error GoTo err
'wkPrint.PrintCommunication = True
With wkPrint.PageSetup
.PaperSize = xlPaperA3
.RightHeader = "&D &T"
.PrintGridlines = True
'.LineNumbering.Active = True
'.PrintTitleColumns = "A:AA"
End With
'Application.PrintCommunication = True
wkPrint.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Name, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Exit Sub
'err:
'MsgBox err.Description
End Sub
Thanks in advance!
You are looking for wkPrint.PageSetup.PrintHeadings = True
Related
I have written the following code tied to a command button to prompt the user to define a save path, export the active sheet to PDF and open it, then delete the sheet after it's been exported and activate a different sheet. The code works to completion but right at the end, I get a the following error:
Run-time error '-2147221080 (800401a8)':
Automation error
Below is my code. Any help would be immensely appreciated.
Private Sub ExceptionPrint_Click()
Sheet_Name = ActiveSheet.Name
PDF_Name = "Exception - " & ActiveSheet.Name & ".pdf"
Set File_Dialog = Application.FileDialog(msoFileDialogFolderPicker)
File_Dialog.AllowMultiSelect = False
File_Dialog.Title = "Select the Desired Location"
If File_Dialog.Show <> -1 Then
Exit Sub
End If
PDF_Name = File_Dialog.SelectedItems(1) & "\" & PDF_Name
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=PDF_Name, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
If Sheets("Data").Range("H12").Value = "W1" Then
Sheets("Week 1").Activate
Sheets("Data").Range("H12").Value = ""
Else
Sheets("Week 1").Activate
Sheets("Data").Range("H12").Value = ""
End If
Application.DisplayAlerts = False
Sheets(Sheet_Name).Delete
Application.DisplayAlerts = True
End Sub
I've tried everything I could think of, but I'm not that great with VBA to begin with.
Assign the active sheet to a reference at the start and use that reference throughout the program. Also try to catch early any errors that the user might make.
Option Explicit
Private Sub ExceptionPrint_Click()
Dim wb As Workbook, wsPDF As Worksheet, PDF_Name As String
' validation
Set wb = ThisWorkbook
Set wsPDF = wb.ActiveSheet
With wsPDF
If .Name = "Week 1" Or .Name = "Data" Then
MsgBox "Sheet " & wsPDF.Name & " must not be selected", vbCritical
Exit Sub
ElseIf WorksheetFunction.CountA(.UsedRange) = 0 Then
MsgBox .Name & " is blank", vbCritical
Exit Sub
End If
End With
' select folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select the Desired Location"
If .Show <> -1 Then Exit Sub
PDF_Name = .SelectedItems(1) & "\Exception - " & wsPDF.Name & ".pdf"
End With
' print and delete
wsPDF.ExportAsFixedFormat Filename:=PDF_Name, Type:=xlTypePDF, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Application.DisplayAlerts = False
wsPDF.Delete
Application.DisplayAlerts = True
' finish
With wb
.Sheets("Week 1").Activate
.Sheets("Data").Range("H12").Value = ""
End With
End Sub
I ended up just leaving a "Delete Sheet" button on the sheet in question rather than having it automatically delete. Thank you everyone.
I am trying to set the default printer when printing to PDF but getting the error "Method ActivePrinter of object _application failed"
Application.ActivePrinter = "Microsoft Print to PDF"
With ActiveSheet.PageSetup
.PaperSize = xlPaperA4
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
"C:\Users\" & Environ$("UserName") & "\Downloads\" & Replace(Worksheets("test").Cells(1, 1), ".", "") & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
How can I set the printer to Microsoft Print to PDF?
Please, copy the next function in a standard module:
Function FindPrinter(ByVal PrinterName As String) As String
Dim arrH, Pr, Printers, Printer As String
Dim RegObj As Object, RegValue As String
Const HKEY_CURRENT_USER = &H80000001
Set RegObj = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
RegObj.Enumvalues HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", Printers, arrH
For Each Pr In Printers
RegObj.getstringvalue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", Pr, RegValue
Printer = Pr & " on " & Split(RegValue, ",")(1)
If InStr(1, Printer, PrinterName, vbTextCompare) > 0 Then
FindPrinter = Printer
Exit Function
End If
Next
End Function
And use it in this way:
Sub testFindPrinter()
Debug.Print FindPrinter("Microsoft Print to PDF")
End Sub
Or for your specific case:
Application.ActivePrinter = FindPrinter("Microsoft Print to PDF")
Please, test it and send some feedback
Just want to ask if how can I export a PDF file with vba? The thing is I do have a 10-F and 10-B sheet. The code below is working in the 10-F sheet. My problem is how can I export the data in the 10-B sheet together with the 10-F? The first page is the data in 10-F while the data in 10-B will be on the second page.
The range for the 10-B sheet is "B10:AD92".
Sub Ver_PDF()
'Create and assign variables
Dim saveLocation As String
Dim rng As Range
lname = ThisWorkbook.Sheets("HOME").Range("K12")
fname = ThisWorkbook.Sheets("HOME").Range("K13")
Name = fname & " " & lname
pdfile = "V-" & Name & ".pdf"
saveLocation = ThisWorkbook.Path & "\V-PDF\" & pdfile
Set rng = Sheets("10-F").Range("B9:AD89")
Dim strFileExists As String
strFileExists = Dir(saveLocation)
If strFileExists <> "" Then
Dim Ret
'~~> Change this to the relevant file path and name
Ret = IsFileOpen(saveLocation)
If Ret = True Then
MsgBox "Please close the PDF file before proceeding...", vbCritical + vbOKOnly, "Error"
Exit Sub
End If
End If
rng.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=saveLocation, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub
Any help is highly appreciated! Thanks!
This code will do what you want. Change the worksheet names in the array as well as the destination path and file name.
Sub ExportAsPDF()
Dim FolderPath As String
Dim FileName As String
FolderPath = "D:\Test PDFs\" ' change to suit: end on back-slash
FileName = "Test" ' change to suit
On Error Resume Next
MkDir FolderPath
On Error GoTo 0
Worksheets(Array("10-F", "10-B")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=FolderPath & FileName & ".PDF", _
OpenAfterPublish:=True, _
IgnorePrintAreas:=False
MsgBox "PDF was successfully created."
Worksheets(1).Select
End Sub
Change OpenAfterPublish to False if you don't want to see the result right away.
I have a code (seen below at the bottom of this message) built by someone else and it has worked very well in excel 2010 but our administration migrated us to excel 2019. Now the same code produces errors. I have also tried checking if there were new add-ins or references in the reference library in vba but have not found anything that removes the errors or allows the code to execute properly.
The function of the code is basically like this:
The code is linked to a pivot table in a worksheet in a workbook. It will ask the user a few questions such as is this a 'RFQ' and then a msg box will open for them to enter a file name. It then asks the user if they wish to have the data added to another worksheet in the same workbook. After all these are answered the code should open an new workbook and copy/paste over data from a hidden worksheet from the original workbook into this new workbook. This new workbook should become the focus and allow the user to make any other changes before they save and close it.
The code automatically saved the new workbook in a location (using a HLink) that is referenced from a cell on another hidden worksheet in the original workbook.
The errors that take place now is this: "The following features cannot be saved in macro-free workbooks: VB Project To save a file with these features, click No, and then choose a macro-enabled file type in the File type list. To continue saving as a macro-free workbook, click Yes.
If the user says yes, the it says the new workbook that was just created 'already exists in this location. Do you want to replace it?"
If you say yes, everything goes blank and you have to restart excel. If you say no, the vba debugger opens to the end of the code highlighting the last part of the code:
ActiveWorkbook.SaveAs FileName:=HLink _ , FileFormat:"xlOpenXMLWorkbook, CreateBackup:=False
I have tried changing some sections of the code. From this:
`'Save
On Error GoTo ErrFileClose:
HLink = (FilePath & "\" & FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;#") & ".xlsx")
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If`
To this:
'Save
On Error GoTo ErrFileClose:
HLink = (FilePath & "\" & FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;#"))
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=51, CreateBackup:=False
End If
And similarly, from this:
'Check if previously created file is open and close it so new one can be saved
ErrFileClose:
FinalFileName = FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;#") & ".xlsx"
Workbooks(FinalFileName).Close SaveChanges:=True
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
To this:
'Check if previously created file is open and close it so new one can be saved
ErrFileClose:
FinalFileName = FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;#")
Workbooks(FinalFileName).Close SaveChanges:=True
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=51, CreateBackup:=False
These changes sometimes help and seem to remove the vb project error but it is not consistent every time I run the macro.
Any help is appreciated as we cannot move forward using this as it stands.
Thanks.
Sub ImportFile()
'
' ImportFile Macro
Call UnprotectAll
'Create Import
Dim curWorkbook As Workbook
Dim ReqType As String
Dim FileName As String
Dim FinalFileName As String
Dim FilePath As String
FilePath = Sheets("X").Range("C3").Value
Dim HLink As String
Application.ScreenUpdating = False
Sheets("Import").Visible = True
Sheets("Import").Copy
ActiveSheet.Unprotect
'Edit import to remove formulas and blank rows
Range("A1:AC500").Value = Range("A1:AC500").Value
Columns("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Set curWorkbook = ActiveWorkbook
Windows("Transactions.xlsm").Activate
Sheets("Import").Visible = False
curWorkbook.Activate
'Save Import
ReqType = MsgBox("Click YES if you are creating an RFQ", vbYesNoCancel)
'vbCancel = 2, vbYes = 6, vbNo = 7
If ReqType = 6 Then
ReqType = "RFQ"
Else
If ReqType = 7 Then
ReqType = "Ordered"
Else
Exit Sub
End If
End If
FileName = InputBox("Please enter the Incident number or other Unique ID Number to save this file as:")
'Cancel Save
If FileName = "" Then
ActiveWorkbook.Close SaveChanges:=False
Call ProtectAll
Application.ScreenUpdating = True
MsgBox ("File Not Created")
Exit Sub
Else
'Save
On Error GoTo ErrFileClose:
HLink = (FilePath & "\" & FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;#") & ".xlsx")
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If
'Add Order to Receive tab ?
If MsgBox("Ok to add this data as Transaction: " & ReqType & "?", vbOKCancel) = vbOK Then
Windows("Transactions.xlsm").Activate
Else
'Do Not add Order to transactions Order - Receipt
ActiveWorkbook.Close SaveChanges:=False
Call ProtectAll
Application.ScreenUpdating = True
MsgBox ("This has not been added as a transaction. Click the HuB button when ready to try again. A new import file will be created and can be saved over the one just created.")
Exit Sub
End If
'AddOrder to Transactions Order - Receipt
ActiveSheet.PivotTables("ToBeOrderedPivot").RowRange.Select
'Remove headers and column 1
Selection.Offset(1, 1).Resize(Selection.Rows.Count - 1, _
Selection.Columns.Count).Select
'Remove Extra Columns
Dim FirstRow As Integer
Dim LastRow As Integer
FirstRow = Selection.Row
LastRow = FirstRow + Selection.Rows.Count - 1
Range("C" & FirstRow & ":F" & LastRow & ",AA" & FirstRow & ":AA" & LastRow & ",L" & FirstRow & ":L" & LastRow).Select
Selection.SpecialCells(xlCellTypeVisible).Copy
'Move to end of Orders table
Sheets("Receive").Select
Count = Range("Orders[Mtl ID]").Rows.Count
Range("B" & Count + 4).Select
'Paste Values
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Set Values
Selection.Offset(0, 8).Columns(1).Value = Selection.Offset(0, 2).Columns(1).Value
If ReqType = "RFQ" Then
Selection.Offset(0, 2).Columns(1).Value = 0
Selection.Offset(0, 7).Columns(1).Value = ReqType
Else: Selection.Offset(0, 2).Columns(1).Value = Selection.Offset(0, 5).Columns(1).Value
End If
Selection.Offset(0, 5).Columns(1).Value = Selection.Offset(0, 3).Columns(1).Value
Selection.Offset(0, 3).Columns(1).Value = Selection.Offset(0, 4).Columns(1).Value
Selection.Offset(0, 4).Columns(1).Value = Selection.Offset(0, 8).Columns(1).Value
Selection.Offset(0, 8).Columns(1).Value = FileName
Selection.Offset(0, 9).Columns(1).Value = Format(Date, "[$-409]yyyy-mm-d;#")
'Sort Table
Call SortReceive
Call ProtectAll
Application.ScreenUpdating = True
'Return to Import File
curWorkbook.Activate
Exit Sub
'Check if previously created file is open and close it so new one can be saved
ErrFileClose:
FinalFileName = FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;#") & ".xlsx"
Workbooks(FinalFileName).Close SaveChanges:=True
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Resume Next
End Sub
I have "Filling form" worksheet where user is filling information and then I have "Print version" worksheet that is actually printing. I am making "CV tool" so user is filling his personal information and then my current VBA is saving end file from "Print version" to xls. and .pdf to the same folder with certain name both files where my "CV tool" is. Some people have experience of 10 years in 10 different work places and others have been only in 2 different companies previously. So before saving to .pdf and .xls my VBA hides rows that are empty to make end result look good.
The problem is that estetically it is not so good looking because some heading of work positions are at the end of the page and work description is continuing on the next page. Is there any way to make some kind of VBA to look for each page in "PrintArea" and if certain block is not fitting to this page VBA will insert "Page Break" before it to move it to the next page?
My current macro below (Sub doitallplease() is main command):
Sub Color()
Dim myRange As Range
Dim cell As Range
Set myRange = ThisWorkbook.Sheets("Print version").Range("Print_Area")
For Each cell In myRange
myRange.Interior.ColorIndex = 0
If cell.HasFormula = True And cell.value = "" And cell.EntireRow.Hidden = False Then Rows(cell.Row).EntireRow.Hidden = True
Next
End Sub
Sub MagicButton()
Dim iFileName$, iRow&, iCol&, iCell As Range, iArr
iFileName = ThisWorkbook.Path & "\CV_" & Sheets("Filling form").Range("F7") & "_" & Sheets("Filling form").Range("F9") & ".xls"
iArr = Array(1, 3, 4): iCol = UBound(iArr) + 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
ThisWorkbook.Sheets("Print version").Copy
With ActiveWorkbook.ActiveSheet
.Buttons.Delete '.Shapes("Button 1").Delete
.UsedRange.value = .UsedRange.value
.SaveAs iFileName, xlExcel8: .Parent.Close
End With
Application.Calculation = xlAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub exportpdfthisfile()
ActiveWorkbook.Sheets("Print version").Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\CV_" & Sheets("Filling form").Range("F7") & "_" & Sheets("Filling form").Range("F9") & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub
Sub doitallplease()
Application.ScreenUpdating = False
ActiveWorkbook.Sheets("Print version").Visible = True
Call Color
Call MagicButton
Call exportpdfthisfile
ActiveWorkbook.Sheets("Filling form").Activate
ActiveWorkbook.Sheets("Print version").Visible = False
Application.ScreenUpdating = True
End Sub