I have cobbled together a VBA script that loops through a list of data, changing the value of a single cell on a summary page. That cell drives a number of formulas. After each iteration, the cell range of interest is saved off as a PDF.
I am looking to avoid having to manually hit enter every time the 'save as' dialog box is generated on each loop. Once I deploy this script, I could be looking at 1k+ iterations.
Sub AlterID()
Dim ws As Worksheet
Dim strPath As String
Dim myFile As Variant
Dim strFile As String
Set ws = Worksheets("Summary Data")
For Each c In Worksheets("Data").Range("A2:A11").Cells
Worksheets("Summary Data").Range("B1").Value = c.Value
strFile = ws.Range("D3").Value
strFile = ThisWorkbook.Path & "\" & strFile
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If myFile <> "False" Then
ws.Range("D3:H9").Select
Selection.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If
Next
End Sub
Sub AlterID()
Dim ws As Worksheet, c As Range
Dim strFile As String
Set ws = Worksheets("Summary Data")
For Each c In Worksheets("Data").Range("A2:A11").Cells
ws.Range("B1").Value = c.Value
strFile = ThisWorkbook.Path & "\" & ws.Range("D3").Value
ws.Range("D3:H9").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next
End Sub
Have you tried turning off application alerts?
Application.DisplayAlerts = False 'before your code
Application.DisplayAlerts = True 'after your code
Edit 1
Here is a sub I use to save a file to a PDF
Sub SaveAsPDF()
Dim myValue As Variant
Dim mySheets As Variant
mySheets = Array("Report")
For Each sh In mySheets
Sheets(sh).PageSetup.Orientation = xlLandscape
Next
uid = InputBox("Enter your UID")
uid = StrConv(uid, vbProperCase)
Application.PrintCommunication = False
With Sheets("Report").PageSetup
.FitToPagesWide = 1
.FitToPagesTall = False
End With
Application.PrintCommunication = True
Dim fName As String
fName = "HMB SOX report for week ending " & ActiveSheet.Range("H4").Text
Call selectPage("Report")
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
"C:\Users\" & uid & "\Desktop\" & fName, :=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, Publish:=False
End With
End Sub
Related
Sub SavetoPDF()
Application.ScreenUpdating = False
Dim UseName As Variant
Dim printRanges As Range
UseName = Application.GetSaveAsFilename( _
InitialFileName:="Report.pdf", _
FileFilter:="PDF files, *.pdf", _
Title:="Export to pdf")
Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=UseName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub
Save to PDF
A Quick Fix
Sub SavetoPDF()
Const PrintAreaAddress As String = "A1:M500"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
' Store print area in a variable.
Dim SavedPrintArea As String: SavedPrintArea = ws.PageSetup.PrintArea
' Change the print area to the required one.
ws.PageSetup.PrintArea = PrintAreaAddress
Application.ScreenUpdating = False
Dim UseName As Variant
UseName = Application.GetSaveAsFilename( _
InitialFileName:="Report.pdf", _
FileFilter:="PDF files, *.pdf", _
Title:="Export to pdf")
wb.Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")).Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=UseName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
' Restore previous print area.
ws.PageSetup.PrintArea = SavedPrintArea
ws.Select
Application.ScreenUpdating = True
End Sub
I have never really worked with VBA and I am getting stuck on a simple problem.
Essentially I have a workbook with multiple worksheets. I Have a Macro which prints all worksheets to pdf. I want to change the macro to only print specific worksheets
Code sofar:
Sub Print_All_pages()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Select
nm = ws.Name
Dim Filepath As String
Filepath = Range("Destination").Value & "\Übersicht Bonus - " & Range("Month").Value & " " & Range("Year").Value & " - " & nm & ".pdf"
Range("A1:N35").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Filepath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=False
Next ws
Worksheets("Main Sheet").Activate
End Sub
I hav tried the following which doesn't work
For Each ws in Worksheets
If ws.Name = "Textbausteine Mail" Or ws.Name = "Overzichten verzenden" Or ws.Name = "Übersicht_Januar" Then
'Do nothing
Else
nm = ws.Name
Dim Filepath As String
Filepath = Range("Destination").Value & "\Übersicht Bonus - " & Range("Month").Value & " " & Range("Year").Value & " - " & ws.Name & ".pdf"
Range("A1:N35").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Filepath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=False
Next ws
Worksheets("Main Sheet").Activate
This however throws me the error compilation error Next without for
Here is the workbook setup:
Any help is greatly appreciated
Export Range to PDF
A Quick Fix
Option Explicit
Sub ExportToPDF()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim FilePathLeft As String
With wb.Worksheets("Main Sheet")
FilePathLeft = .Range("Destination").Value & "\Übersicht Bonus - " _
& .Range("Month").Value & " " & .Range("Year").Value & " - "
End With
Dim ws As Worksheet
Dim FilePath As String
For Each ws In wb.Worksheets
Select Case ws.Name
' do NOT export:
Case "Textbausteine Mail", "Overzichten verzenden", "Übersicht_Januar"
' do export:
Case Else
FilePath = FilePathLeft & ws.Name & ".pdf"
ws.Range("A1:N35").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FilePath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=False
End Select
Next ws
End Sub
I'm trying to create separate PDFs for each sheet in a selection of sheets, with a name determined by the sheet name and the contents of one cell.
The code is as follows:
Sub SaveWorksheetsAsPDFs()
Dim sFile As String
Dim sPath As String
Dim sh As Object
Dim InvDate As String
With ActiveWorkbook
sPath = .Path & "\"
For Each sh In ActiveWindow.SelectedSheets
InvDate = Format(Range("G9"), "dd-mm-yy")
sFile = sh.Name & " - Invoice - " & InvDate & ".pdf"
sh.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sPath & sFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next sh
End With
End Sub
Separate PDFs are created and named correctly, however, the PDF contains all the selected sheets instead of one.
With my experience, i've seen that the ExportAsFixedFormat always exports all selected sheets.
You can come around this by saying sh.Select after your For Each, and then it should works as you describe in the OP.
Edited code:
Sub SaveWorksheetsAsPDFs()
Dim sFile As String
Dim sPath As String
Dim sh As Object
Dim InvDate As String
With ActiveWorkbook
sPath = .Path & "\"
For Each sh In ActiveWindow.SelectedSheets
sh.Select '<----- New LINE
InvDate = Format(Range("G9"), "dd-mm-yy")
sFile = sh.Name & " - Invoice - " & InvDate & ".pdf"
sh.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sPath & sFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=False
Next sh
End With
End Sub
Hope this helps you achive your goal. :)
So I'm using this macro to save individual excel worksheets as their own PDF when run:
Sub SaveWorksheetsAsPDFs()
Dim sFile As String
Dim sPath As String
Dim wks As Worksheet
With ActiveWorkbook
sPath = .Path & "\"
For Each wks In .Worksheets
sFile = wks.Name & ".pdf"
wks.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sPath & sFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next wks
End With
End Sub
I would just like to add to it to not start from a certain worksheet or to exclude certain worksheets. Any clue how?
You can use Select Case to specify sheetnames to ignore, as shown. Simply replace the "IgnoreSheet1", "IgnoreSheet2" with the actual sheet names you want skipped. It's just a comma delimited list, so add as many as you want.
Sub SaveWorksheetsAsPDFs()
Dim sFile As String
Dim sPath As String
Dim wks As Worksheet
With ActiveWorkbook
sPath = .Path & "\"
For Each wks In .Worksheets
Select Case wks.Name
Case "IgnoreSheet1", "IgnoreSheet2" 'Do nothing
Case Else
'Code here to run on the other sheets
sFile = wks.Name & ".pdf"
wks.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sPath & sFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Select
Next wks
End With
End Sub
I have a code that prints a selected area in a worksheet to PDF and allows user to select folder and input file name.
There are two things I want to do though:
Is there a way that the PDF file can create a folder on the users desktop and save the file with a file name based on specific cells in the sheet?
If multiple copies of the same sheet are saved/printed to PDF can each copy have a number eg. 2, 3 in the filename based on the copy number?**
Here is the code I have so far:
Sub PrintRentalForm()
Dim filename As String
Worksheets("Rental").Activate
filename = Application.GetSaveAsFilename(InitialFileName:="", _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Path and Filename to save")
If filename <> "False" Then
With ActiveWorkbook
.Worksheets("Rental").Range("A1:N24").ExportAsFixedFormat Type:=xlTypePDF, _
filename:=filename, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End With
End If
filename = Application.GetSaveAsFilename(InitialFileName:="", _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Path and Filename to save")
If filename <> "False" Then
With ActiveWorkbook
.Worksheets("RentalCalcs").Range("A1:N24").ExportAsFixedFormat Type:=xlTypePDF, _
filename:=filename, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
End If
End Sub`
UPDATE:
I have changed the code and references and it now works. I have linked the code to a commandbutton on the Rental Sheet -
Private Sub CommandButton1_Click()
Dim filenamerental As String
Dim filenamerentalcalcs As String
Dim x As Integer
x = Range("C12").Value
Range("C12").Value = x + 1
Worksheets("Rental").Activate
Path = CreateObject("WScript.Shell").specialfolders("Desktop")
filenamerental = Path & "\" & Sheets("Rental").Range("O1")
'ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
Worksheets("Rental").Range("A1:N24").Select
Selection.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=filenamerental, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Worksheets("RentalCalcs").Activate
Path = CreateObject("WScript.Shell").specialfolders("Desktop")
filenamerentalcalcs = Path & "\" & Sheets("RentalCalcs").Range("O1")
'ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
Worksheets("RentalCalcs").Range("A1:N24").Select
Selection.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=filenamerentalcalcs, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Worksheets("Rental").Activate
Range("D4:E4").Select
End Sub
Hopefully this is self explanatory enough. Use the comments in the code to help understand what is happening. Pass a single cell to this function. The value of that cell will be the base file name. If the cell contains "AwesomeData" then we will try and create a file in the current users desktop called AwesomeData.pdf. If that already exists then try AwesomeData2.pdf and so on. In your code you could just replace the lines filename = Application..... with filename = GetFileName(Range("A1"))
Function GetFileName(rngNamedCell As Range) As String
Dim strSaveDirectory As String: strSaveDirectory = ""
Dim strFileName As String: strFileName = ""
Dim strTestPath As String: strTestPath = ""
Dim strFileBaseName As String: strFileBaseName = ""
Dim strFilePath As String: strFilePath = ""
Dim intFileCounterIndex As Integer: intFileCounterIndex = 1
' Get the users desktop directory.
strSaveDirectory = Environ("USERPROFILE") & "\Desktop\"
Debug.Print "Saving to: " & strSaveDirectory
' Base file name
strFileBaseName = Trim(rngNamedCell.Value)
Debug.Print "File Name will contain: " & strFileBaseName
' Loop until we find a free file number
Do
If intFileCounterIndex > 1 Then
' Build test path base on current counter exists.
strTestPath = strSaveDirectory & strFileBaseName & Trim(Str(intFileCounterIndex)) & ".pdf"
Else
' Build test path base just on base name to see if it exists.
strTestPath = strSaveDirectory & strFileBaseName & ".pdf"
End If
If (Dir(strTestPath) = "") Then
' This file path does not currently exist. Use that.
strFileName = strTestPath
Else
' Increase the counter as we have not found a free file yet.
intFileCounterIndex = intFileCounterIndex + 1
End If
Loop Until strFileName <> ""
' Found useable filename
Debug.Print "Free file name: " & strFileName
GetFileName = strFileName
End Function
The debug lines will help you figure out what is happening if you need to step through the code. Remove them as you see fit. I went a little crazy with the variables but it was to make this as clear as possible.
In Action
My cell O1 contained the string "FileName" without the quotes. Used this sub to call my function and it saved a file.
Sub Testing()
Dim filename As String: filename = GetFileName(Range("o1"))
ActiveWorkbook.Worksheets("Sheet1").Range("A1:N24").ExportAsFixedFormat Type:=xlTypePDF, _
filename:=filename, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub
Where is your code located in reference to everything else? Perhaps you need to make a module if you have not already and move your existing code into there.